SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00031 SORTING ROUTINES 1 05-28-9313:57ALL SWAG SUPPORT TEAM ALPHAREC.PAS IMPORT 7 { Alphabetic Rec Sort }ππProcedure SortIt(Key : Byte);πVarπ I, J : Byte;ππProcedure Swapper;πVarπ T : Member;ππbeginπ T := Memrec[I];π MemRec[I] := MemRec[J];π MemRec[J] := T;πend;ππbeginπ For I := 1 to MaxMem - 1 DOπ For J := I To MaxMem do beginπ Case Key OFπ 1 : if MemRec[I].Firstname < MemRec[J].FirstName then Swapper;π 2 : if MemRec[I].LastName < MemRec[J].LastName then Swapper;π 3 : if MemRec[I].Points < MemRec[J].Points then Swapper;π end;πend;ππ{πAnother Alternative would be to do as C does, make a Generic Sort routineπwhere you pass it a Function that returns > 0 if Record1 is greater thanπRecord2, < 0 if Record1 is Less than Record2, and 0 if they are the same.π}π 2 05-28-9313:57ALL SWAG SUPPORT TEAM ANAGRAM1.PAS IMPORT 196 (* Start of PART 1 of 7 *)ππ(***********************************************************************π Contest 3 Entry : Anagram Sort by Guy McLoughlinπ Compiler : Borland Pascal 7.0π***********************************************************************)ππ {.$DEFINE DebugMode}ππ {$IFDEF DebugMode}π {$A+,B-,D+,E-,F-,G+,I+,L+,N-,O-,P-,Q+,R+,S+,T+,V+,X-}π {$ELSE}π {$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}π {$endIF}ππ {$M 16384,374784,655360}ππProgram Anagram_Sort;ππConstπ co_MaxWord = 2500;π co_MaxSize = 65519;π co_SafeSize = 64500;ππTypeπ Char_12 = Array[1..12] of Char;ππ st_4 = String[4];π st_10 = String[10];π st_80 = String[80];ππ byar_26 = Array[97..122] of Byte;ππ po_Buff = ^byar_Buffer;π byar_Buffer = Array[1..co_MaxSize] of Byte;ππ porc_Word = ^rc_Word;π rc_Word = Recordπ wo_Pos : Word;π ar_LtrChk : Char_12;π st_Word : st_10π end;ππ poar_Word = Array[0..co_MaxWord] of porc_Word;ππ porc_AnaGroup = ^rc_AnaGroup;π rc_AnaGroup = Recordπ wo_Pos : Word;π st_Group : st_80π end;ππ poar_AnaGroup = Array[0..co_MaxWord] of porc_AnaGroup;π poar_Generic = Array[0..co_MaxWord] of Pointer;ππ (***** Check For I/O errors. *)π (* *)π Procedure CheckIOerror;π Varπ by_Error : Byte;π beginπ by_Error := ioresult;π if (by_Error <> 0) thenπ beginπ Writeln('Input/Output error = ', by_Error);π haltπ endπ end; (* CheckIOerror. *)ππ (***** Display HEAP error message. *)π (* *)π Procedure HeapError;π beginπ Writeln('Insuficient free HEAP memory');π haltπ end; (* HeapError. *)ππTypeπ Item = Pointer;π ar_Item = poar_Generic;π CompFunc = Function(Var Item1, Item2 : Item) : Boolean;ππ (* end of PART 1 of 7 *)π (* Start of PART 2 of 7 *)ππ (***** QuickSort routine. *)π (* *)π Procedure QuickSort({update} Var ar_Data : ar_Item;π {input } wo_Left,π wo_Right : Word;π LessThan : CompFunc);π Varπ Pivot,π TempItem : Item;π wo_Index1,π wo_Index2 : Word;π beginπ wo_Index1 := wo_Left;π wo_Index2 := wo_Right;π Pivot := ar_Data[(wo_Left + wo_Right) div 2];π Repeatπ While LessThan(ar_Data[wo_Index1], Pivot) doπ inc(wo_Index1);π While LessThan(Pivot, ar_Data[wo_Index2]) doπ dec(wo_Index2);π if (wo_Index1 <= wo_Index2) thenπ beginπ TempItem := ar_Data[wo_Index1];π ar_Data[wo_Index1] := ar_Data[wo_Index2];π ar_Data[wo_Index2] := TempItem;π inc(wo_Index1);π dec(wo_Index2)π endπ Until (wo_Index1 > wo_Index2);π if (wo_Left < wo_Index2) thenπ QuickSort(ar_Data, wo_Left, wo_Index2, LessThan);π if (wo_Index1 < wo_Right) thenπ QuickSort(ar_Data, wo_Index1, wo_Right, LessThan)π end; (* QuickSort. *)ππ (***** Sort Function to check if anagram-Word's are in sorted order *)π (* *)π Function AlphaSort(Var Item1, Item2 : Item) : Boolean; Far;π beginπ AlphaSort := (porc_Word(Item1)^.st_Word < porc_Word(Item2)^.st_Word)π end; (* AlphaSort. *)ππ (***** Sort Function to check: *)π (* *)π (* 1 - If anagram-Words are sorted by length. *)π (* 2 - If anagram-Words are sorted by anagram-group. *)π (* 3- If anagram-Words are sorted alphabeticly. *)π (* *)π Function Sort1(Var Item1, Item2 : Item) : Boolean; Far;π beginπ if (porc_Word(Item1)^.st_Word[0] <>π porc_Word(Item2)^.st_Word[0]) thenπ Sort1 := (porc_Word(Item1)^.st_Word[0] <π porc_Word(Item2)^.st_Word[0])π elseπ if (porc_Word(Item1)^.ar_LtrChk <>π porc_Word(Item2)^.ar_LtrChk) thenπ Sort1 := (porc_Word(Item1)^.ar_LtrChk <π porc_Word(Item2)^.ar_LtrChk)π elseπ Sort1 := (porc_Word(Item1)^.wo_Pos < porc_Word(Item2)^.wo_Pos)π end; (* Sort1. *)ππ (***** Sort Function to check: *)π (* *)π (* If anagram-group Strings are sorted alphabeticly. *)π (* *)π Function Sort2(Var Item1, Item2 : Item) : Boolean; Far;π beginπ Sort2 := (porc_AnaGroup(Item1)^.wo_Pos <π porc_AnaGroup(Item2)^.wo_Pos)π end; (* Sort2. *)ππ (* end of PART 2 of 7 *)π (* Start of PART 3 of 7 *)ππ (***** Check if the anagram-Word table is in sorted order. *)π (* *)π Function TableSorted({input } Var ar_Data : poar_Word;π wo_Left,π wo_Right : Word) : {output} Boolean;π Varπ wo_Index : Word;π beginπ (* Set Function result to True. *)π TableSorted := True;ππ (* Loop through all but the last Word in the anagram- *)π (* Word "table". *)π For wo_Index := wo_Left to pred(wo_Right) doπ (* Check if the current and next anagram-Words are not *)π (* sorted. *)π if (ar_Data[wo_Index]^.st_Word >π ar_Data[succ(wo_Index)]^.st_Word) thenπ beginπ (* Set Function result to False, and break the "for" *)π (* loop. *)π TableSorted := False;π breakπ endπ end; (* TableSorted. *)ππ (***** Pack bits 0,1,2 of each Byte in 26 Byte Array into 10 Chars. *)π (* *)π Procedure PackBits({input } Var byar_Temp : byar_26;π {output} Var Char_Temp : Char_12);π beginπ Char_Temp[ 1] := chr((byar_Temp[ 97] and $7) shl 5 +π (byar_Temp[ 98] and $7) shl 2 +π (byar_Temp[ 99] and $6) shr 1);π Char_Temp[ 2] := chr((byar_Temp[ 99] and $1) shl 7 +π (byar_Temp[100] and $7) shl 4 +π (byar_Temp[101] and $7) shl 1 +π (byar_Temp[102] and $4) shr 2);π Char_Temp[ 3] := chr((byar_Temp[102] and $3) shl 6 +π (byar_Temp[103] and $7) shl 3 +π (byar_Temp[104] and $7));π Char_Temp[ 4] := chr((byar_Temp[105] and $7) shl 5 +π (byar_Temp[106] and $7) shl 2 +π (byar_Temp[107] and $6) shr 1);π Char_Temp[ 5] := chr((byar_Temp[107] and $1) shl 7 +π (byar_Temp[108] and $7) shl 4 +π (byar_Temp[109] and $7) shl 1 +π (byar_Temp[110] and $4) shr 2);π Char_Temp[ 6] := chr((byar_Temp[110] and $3) shl 6 +π (byar_Temp[111] and $7) shl 3 +π (byar_Temp[112] and $7));π Char_Temp[ 7] := chr((byar_Temp[113] and $7) shl 5 +π (byar_Temp[114] and $7) shl 2 +π (byar_Temp[115] and $6) shr 1);π Char_Temp[ 8] := chr((byar_Temp[115] and $1) shl 7 +π (byar_Temp[116] and $7) shl 4 +π (byar_Temp[117] and $7) shl 1 +π (byar_Temp[118] and $4) shr 2);π Char_Temp[ 9] := chr((byar_Temp[118] and $3) shl 6 +π (byar_Temp[119] and $7) shl 3 +π (byar_Temp[120] and $7));π Char_Temp[10] := chr((byar_Temp[121] and $7) shl 5 +π (byar_Temp[122] and $7) shl 2)π end; (* PackBits. *)ππVarπ po_Buffer : po_Buff;ππ by_Index,π by_LastAnagram,π by_CurrentWord : Byte;ππ wo_Index,π wo_ReadIndex,π wo_TableIndex,π wo_BufferIndex,π wo_CurrentIndex : Word;ππ (* end of PART 3 of 7 *)π (* Start of PART 4 of 7 *)ππ st_Temp : st_4;ππ byar_LtrChk : byar_26;ππ fi_Temp : File;ππ rcar_Table : poar_Word;ππ rcar_Groups : poar_AnaGroup;πππ (* Main Program execution block. *)πbeginπ (* If there is sufficient room, allocate the main data- *)π (* buffer on the HEAP. *)π if (maxavail > co_MaxSize) thenπ new(po_Buffer)π elseπ (* Else, inform user of insufficient HEAP memory, and *)π (* halt the Program. *)π HeapError;ππ (* Clear the data-buffer. *)π fillChar(po_Buffer^, co_MaxSize, 0);ππ (* Initialize counter Variable. *)π wo_Index := 0;ππ (* While the counter is less than co_MaxWord do... *)π While (co_MaxWord > wo_Index) doππ (* If there is sufficient memory, allocate another *)π (* anagram-Word Record on the HEAP. *)π if (maxavail > sizeof(rc_Word)) thenπ beginπ inc(wo_Index);π new(rcar_Table[wo_Index]);π fillChar(rcar_Table[wo_Index]^, sizeof(rc_Word), 0);π endπ elseπ (* Else, inform user of insufficient HEAP memory, and *)π (* halt the Program. *)π HeapError;ππ (* Initialize counter Variable. *)π wo_Index := 0;ππ (* While the counter is less than co_MaxWord do... *)π While (co_MaxWord > wo_Index) doππ (* If there is sufficient memory, allocate another *)π (* anagram-group String on the HEAP. *)π if (maxavail > sizeof(rc_AnaGroup)) thenπ beginπ inc(wo_Index);π new(rcar_Groups[wo_Index]);π fillChar(rcar_Groups[wo_Index]^, sizeof(rc_AnaGroup), 32);π endπ elseπ (* Else, inform user of insufficient HEAP memory, and *)π (* halt the Program. *)π HeapError;ππ (* Attempt to open File containing the anagram-Words. *)π assign(fi_Temp, 'WordLIST.DAT');ππ (* Set Filemode to "read-only". *)π Filemode := 0;π {$I-}π reset(fi_Temp, 1);π {$I+}π (* Check For I/O errors. *)π if (ioresult <> 0) thenπ beginπ Writeln('Error opening anagram data File ---> WordLIST.DAT');π haltπ end;π (* Read-in the entire anagram list into the data-buffer *)π blockread(fi_Temp, po_Buffer^, co_MaxSize, wo_ReadIndex);ππ (* end of PART 4 of 7 *)π (* Start of PART 5 of 7 *)ππ (* Check For I/O errors. *)π CheckIOerror;ππ close(fi_Temp);ππ (* Check For I/O errors. *)π CheckIOerror;ππ (* Initialize index Variables. *)π wo_TableIndex := 0;π wo_BufferIndex := 0;ππ (* Repeat...Until all data in the data-buffer has been *)π (* processed. *)π Repeatππ (* Repeat...Until a valid anagram-Word Character has *)π (* been found, or the complete data-buffer has been *)π (* processed. *)π Repeatπ inc(wo_BufferIndex)π Until ((po_Buffer^[wo_BufferIndex] > 96)π and (po_Buffer^[wo_BufferIndex] < 123))π or (wo_BufferIndex > wo_ReadIndex);ππ (* If the complete data-buffer has been processed then *)π (* break the Repeat...Until loop. *)π if (wo_BufferIndex > wo_ReadIndex) thenπ break;ππ (* Advance the anagram-Word "table" index. *)π inc(wo_TableIndex);ππ (* Clear the "letter check" Byte-Array Variable. *)π fillChar(byar_LtrChk, sizeof(byar_26), 0);ππ (* Repeat...Until not an anagram-Word Character, or *)π (* complete data-buffer has been processed. *)π Repeatππ (* With the current anagram-Word Record do... *)π With rcar_Table[wo_TableIndex]^ doπ beginπ (* Record the number of each alphabetical Character in *)π (* the anagram-Word. *)π inc(byar_LtrChk[po_Buffer^[wo_BufferIndex]]);ππ (* Advance the String length-Character. *)π inc(st_Word[0]);ππ (* Add the current anagram-Word Character to anagram- *)π (* Word String. *)π st_Word[ord(st_Word[0])] :=π chr(po_Buffer^[wo_BufferIndex]);ππ (* Advance the data-buffer index. *)π inc(wo_BufferIndex)ππ endπ Until (po_Buffer^[wo_BufferIndex] < 97)π or (po_Buffer^[wo_BufferIndex] > 122)π or (wo_BufferIndex > wo_ReadIndex);ππ (* Pack bits 0,1,2 of each Character in "letter-check" *)π (* Variable, to store Variable as 10 Char data. This *)π (* reduces memory storage requirements by 16 Bytes For *)π (* each anagram-Word, and makes data faster to sort. *)π PackBits(byar_LtrChk, rcar_Table[wo_TableIndex]^.ar_LtrChk);ππ Until (wo_BufferIndex > wo_ReadIndex);ππ (* Check if the Array of anagram-Words in the "table" *)π (* Array are sorted. If not then sort them. *)π if not TableSorted(rcar_Table, 1, wo_TableIndex) thenπ QuickSort(poar_Generic(rcar_Table), 1, wo_TableIndex, AlphaSort);ππ (* Record the position of all the anagram-Words on the *)π (* "table" Array. This will be used as a faster sorting *)π (* index. *)π For wo_Index := 1 to wo_TableIndex doπ rcar_Table[wo_Index]^.wo_Pos := wo_Index;ππ (* end of PART 5 of 7 *)π (* Start of PART 6 of 7 *)ππ (* QuickSort the "table" of anagram Words, using Sort1 *)π (* routine. *)π QuickSort(poar_Generic(rcar_Table), 1, wo_TableIndex, Sort1);ππ (* Attempt to open a File to Write sorted data to. *)π assign(fi_Temp, 'SORTED.DAT');π {$I-}π reWrite(fi_Temp, 1);ππ (* Check For I/O errors. *)π CheckIOerror;ππ (* Set the temporary String to ', ' + Cr + Lf. *)π st_Temp := ', ' + #13#10;ππ (* Reset the loop index. *)π wo_Index := 1;ππ (* Repeat...Until all anagram-Word on "table" Array are *)π (* processed. *)π Repeatππ (* Reset the counter Variables. *)π by_LastAnagram := 0;π by_CurrentWord := 0;ππ (* While the next anagram-Word belongs to the same *)π (* anagram-group, advance the by_LastAnagram Variable. *)π While (rcar_Table[(wo_Index + by_LastAnagram)]^.ar_LtrChk =π rcar_Table[succ(wo_Index + by_LastAnagram)]^.ar_LtrChk) doπ inc(by_LastAnagram);ππ (* Repeat...Until next anagram-Word is not in the same *)π (* anagram group. *)π Repeatππ (* With current anagram group do... *)π With rcar_Groups[(wo_Index + by_CurrentWord)]^ doπ beginππ (* Move the first anagram-Word in "table" Array to the *)π (* current anagram group-String. *)π move(rcar_Table[(wo_Index + by_CurrentWord)]^.st_Word[1],π st_Group[1], ord(rcar_Table[(wo_Index +π by_CurrentWord)]^.st_Word[0]));ππ (* Set the length-Char of current anagram-String to 12. *)π st_Group[0] := #12;ππ (* Record the first anagram-Word position. *)π wo_Pos := rcar_Table[(wo_Index + by_CurrentWord)]^.wo_Pos;ππ (* Loop from 0 to total number of anagrams in the group *)π For by_Index := 0 to by_LastAnagram doππ (* If the loop index is not equal the the current *)π (* anagram-Word, then... *)π if (by_Index <> by_CurrentWord) thenπ beginππ (* Add the next anagram-Word to the anagram-String. *)π move(rcar_Table[(wo_Index + by_Index)]^.st_Word[1],π st_Group[succ(length(st_Group))],π ord(rcar_Table[(wo_Index +π by_Index)]^.st_Word[0]));ππ (* Record the length of the anagram-Word added to the *)π (* anagram-String. *)π inc(st_Group[0],π ord(rcar_Table[(wo_Index +π by_Index)]^.st_Word[0]));ππ (* If the current anagram-Word is not the last anagram- *)π (* Word of the anagram-group, and the loop-index is *)π (* less than the last anagram-Word, or the loop-index *)π (* is less than the 2nd to last anagram-Word in group *)π if ((by_CurrentWord <> by_LastAnagram) andπ (by_Index < by_LastAnagram))π or (by_Index < pred(by_LastAnagram)) thenπ beginππ (* end of PART 6 of 7 *)π (* Start of PART 7 of 7 *)ππ (* Add the comma and space Character to anagram-String. *)π move(st_Temp[1],π st_Group[succ(length(st_Group))], 2);π inc(st_Group[0], 2)π endπ end;ππ (* Add the CR + Lf to anagram String. *)π move(st_Temp[3], st_Group[succ(length(st_Group))], 2);π inc(st_Group[0], 2);ππ (* Advance the currrent anagram-Word index. *)π inc(by_CurrentWord)ππ endπ Until (by_CurrentWord > by_LastAnagram);ππ (* Advance the anagram-group index by the current *)π (* anagram-Word index. *)π inc(wo_Index, by_CurrentWord);ππ Until (wo_Index > wo_TableIndex);ππ (* QuickSort the anagram-Strings, using Sort2. *)π QuickSort(poar_Generic(rcar_Groups), 1, wo_TableIndex, Sort2);ππ (* Initialize loop control Variable. *)π wo_CurrentIndex := 1;ππ (* Repeat Until all the anagram Words in the "table" *)π (* Array have been processed. *)π Repeatππ (* Initialize loop control Variable. *)π wo_BufferIndex := 1;ππ (* Place all the anagram-Strings in the data-buffer. *)π While (wo_CurrentIndex <= wo_TableIndex)π and (wo_BufferIndex < co_SafeSize) doπ With rcar_Groups[wo_CurrentIndex]^ doπ beginπ (* Place current anagram-String in the data-buffer. *)π move(st_Group[1], po_Buffer^[wo_BufferIndex],π length(st_Group));ππ (* Advance the data-buffer index by length of anagram- *)π (* String. *)π inc(wo_BufferIndex, length(st_Group));ππ (* Advance current anagram-String index. *)π inc(wo_CurrentIndex)ππ end;ππ (* Write the anagram Text data in the buffer to disk. *)π blockWrite(fi_Temp, po_Buffer^[1], pred(wo_BufferIndex));ππ (* Check For I/O errors. *)π CheckIOerror;ππ Until (wo_CurrentIndex >= wo_TableIndex);ππ (* Close the sorted anagram-Text File. *)π close(fi_Temp);ππ (* Check For I/O errors. *)π CheckIOerrorππend.ππ (* end of PART 7 of 7 *)π{ Hi, to All:ππ ...I gather that the 3rd Programming contest (Anagram Word sort)π is officially over, and am now posting my entry's source-code.ππ This Program should execute in well under 1 second on a 486-33π ram-disk. (It's about 3.21 sec on my 386sx-25) The final compiledπ size of the .EXE is 7360 Bytes.ππ ...I've commented the h*ll out of my source-code, so it's a bitπ on the big side.ππ ...Here is a "quick" run-down of how it works:ππ 1- Creates a 60K buffer on the HEAP.ππ 2- Creates an Array table to store all the anagram Wordsπ and data about each Word, on the HEAP.ππ 3- Creates an Array of anagram-group Strings on the HEAP.ππ 4- Read the entire anagram-Word input File WordLIST.DATπ into the 60K buffer in 1 big chunk.ππ 5- Finds all the anagram-Words in the buffer, and assignsπ their data to the anagram-Word table on the HEAP.ππ 6- Each letter of every anagram-Word is Recorded in anπ Array of 26 Bytes. Then the first 3 bits of each ofπ the 26 Bytes is packed, so that this data can beπ stored in a 10 Character Array in each anagram-Wordπ table Record. (The bits are packed to save space andπ to make the sorting faster.) This method allows forπ a maximum of 7 of the same letter in each Word, whichπ should be sufficient For this contest.ππ 7- The table of anagram Records is then checked to see ifπ the anagram-Words are in sorted order. (In this contestπ the original input File is in sorted order.) If they areπ not in sorted order, QuickSort is called to put theπ Words (actually Pointers to the Words) in order.ππ 8- Now that the anagram-Words are in sorted order, theirπ position in the anagram-Word table is Recorded in aπ position field within each anagram-Word Record.ππ 9- The table of anagram-Word Records is now sorted usingπ a multi-key QuickSort. This will sort the anagram-Wordπ Records by:π 1- Length of anagram-Word.π 2- Letters that each anagram-Word contains.π 3- Alphabeticly.ππ ...This multi-key sort will establish the anagram groups,π and sort the members of each group alphabeticly.ππ 10- Open the sorted output File.ππ 11- Create N number of anagram-Strings from N mumber of anagram-π Words in each anagram-group. Keeping the anagram Words inπ the String in sorted order.ππ 12- QuickSort the anagram-group Strings into alphabetical order.ππ 13- Place all the sorted anagram-group Strings back into theπ 60K buffer.ππ 14- Write the entire buffer to the SORTED.DAT File, and closeπ this File.ππ NOTES: Well this is the first time I've figured out how to doπ multi-key QuickSorts, which I wasn't sure was possibleπ at first.ππ I also tried using a 32-bit CRC value to identify theπ anagram-groups which ran even faster, but should notπ be considered a "safe" method, as it's accuracy is onlyπ guaranteed For 2-7 Character Words.ππ File I/O and repetitive loops are usually the big speedπ killers in these Types of contests, so I always try toπ keep them to a minimum.ππ ...My entry could possibly be tweaked further still,π but I've got a life. <g>ππ} 3 05-28-9313:57ALL SWAG SUPPORT TEAM ANAGRAM2.PAS IMPORT 125 { ANAGRAM. --------------------------------------------------------------------π Raphaël Vanney, 01/93ππ Purpose : Reads a list of Words 4 to 10 Characters long from a Fileπ named 'LIST.#1', outputs a list of anagrams founds in aπ specified format to a File named 'ANAGRAM.RES'.ππ Note : I commented-out the source using a langage, say English, whichπ I'm not Really fluent in ; please forgive mistakes.π------------------------------------------------------------------------------}ππ{$m 8192,65536,655360}π{$a+,d+,e-,f-,g+,i+,l+,n-,o-,q-,r-,s-,v+}ππ{$b-} { Turns off complete Boolean evaluation ; this allows easiestπ combined Boolean tests. }ππUses Crt,π Objects ;ππConstπ MaxWordLen = 10 ; { Offically specified by GP ! }π CntAnagrams : Word = 0 ; { Actually, this counter shows the }π { number of Words found in the }π { output File. }π OutFileName = 'ANAGRAM.RES' ;πππType TWordString = String[MaxWordLen] ;ππ { TWordCollection.π This Object will be used to store the Words in a sorted fashion. Asπ long as the input list is already sorted, it could have inheritedπ from TCollection, put there is no big penalty using a sorted one. }ππ TWordCollection =π Object (TSortedCollection)π Function KeyOf(Item : Pointer) : Pointer ; Virtual ;π Function Compare(Key1, Key2 : Pointer) : Integer ; Virtual ;π Procedure FreeItem(Item : Pointer) ; Virtual ;π end ;π PWordCollection = ^TWordCollection ;ππ { TWord.π This is the Object we'll use to store a Word. Each Word knows :π - it's 'Textual form' : Itπ - the first of it's anagrams, if it has been found to be theπ anagram of another Word,π - the next of it's anagrams, in the same condition. }ππ PWord = ^TWord ;π TWord =π Objectπ It : TWordString ;π FirstAng : PWord ;π NextAng : PWord ;ππ Constructor Init(Var Wrd : TWordString) ;π Destructor Done ;π end ;ππVar WordsList : PWordCollection ; { The main list of Words }π OrgMem : LongInt ; { Original MemAvail }π UsedMem : LongInt ; { Amount of RAM used }ππ{-------------------------------------- TWord --------------------------------}ππConstructor TWord.Init ;πbeginπ It:=Wrd ;π FirstAng:=Nil ;π NextAng:=Nil ;πend ;ππDestructor TWord.Done ;πbeginπend ;ππ{-------------------------------------- TWordCollection ----------------------}π{ The following methods are not commented out, since they already are inπ Turbo-Pascal's documentations, and they do nothing unusual. }ππFunction TWordCollection.KeyOf ;πbeginπ KeyOf:=Addr(PWord(Item)^.It) ;πend ;ππFunction TWordCollection.Compare ;πVar k1 : PString Absolute Key1 ;π k2 : PString Absolute Key2 ;πbeginπ If k1^>k2^π Then Compare:=1π Else If k1^<k2^π Then Compare:=-1π Else Compare:=0 ;πend ;ππProcedure TWordCollection.FreeItem ;πbeginπ Dispose(PWord(Item), Done) ;πend ;ππ{-------------------------------------- Utilities ----------------------------}ππProcedure CleanUp(Var Wrd : TWordString) ;π{ Cleans-up a Word, in Case there would be dirty Characters in the input File }πVar i : Integer ;πbeginπ { Removes trailing spaces ; not afraid of empty Strings }π While Wrd[Length(Wrd)]=' ' Do Dec(Wrd[0]) ;π { Removes any suspect Character }π i:=1 ;π While (i<=Length(Wrd)) Doπ beginπ If Wrd[i]<#33 Then Delete(Wrd, i, 1)π Else Inc(i) ;π end ;πend ;ππFunction PadStr(St : TWordString ; Len : Integer) : String ;π{ Returns a String padded With spaces, of the specified length }πVar i : Integer ;π Tmp : String ;πbeginπ Tmp:=St ;π For i:=Length(Tmp)+1 To Len Do Tmp[i]:=' ' ;π Tmp[0]:=Chr(Len) ;π PadStr:=Tmp ;πend ;ππ{-----------------------------------------------------------------------------}ππFunction AreAnagrams(Var WordA, WordB : TWordString) : Boolean ;π{ Tells whether two Words are anagrams of each other ; assumes the Wordsπ are 'clean' (No Up/Low Case checking, no dirty Characters...)ππ Optimizing hint : Passing parameters by address _greatly_ enhances overallπ speed ; anyway, we'll use a local copy of one of the two, since the usedπ algorithms needs to modify one of the two Words. }ππAssembler ;πVar WordC : TWordString ; { Local copy of WordB }πAsmπ Push DS { Let's save the Data segment... }π LDS SI, WordA { Load WordA's address in ES:DI }π Mov AL, [SI] { Load length Byte into AL }π LDS SI, WordB { Load WordB's address }π Cmp AL, [SI] { Compare lengthes }π JNE @NotAng { <>lengthes, not anagrams }ππ LDS SI, WordBππ { Let's make a local copy of WordB ; enhanced version of TP's "Move" }π ClD { Clear direction flag }π Push SSπ Pop ES { Segment part of WordC's address }π LEA DI, WordC { Offset part of it }π Mov CL, DS:[SI] { Get length Byte }π XOr CH, CH { Make it a Word }π Mov DL, CL { Save length For later use }π Inc CX { # of Bytes to store the String }π ShR CX, 1 { We'll copy Words ; CF is importt }π Rep MovSW { Copy WordB to WordC }π JNC @NoByteπ MovSB { Copy last Byte }π@NoByte:π LDS SI, WordA { DS:SI contains WordA's address }π Inc SI { SI points to first Char of WordA }π Mov DH, DL { Use DH as a loop counter }π LEA BX, WordC { Load offset of WordC in BX }π Inc BX { Skip length Byte }π { For each letter in WordA, search it in WordB ; if found, mark it asπ 'used' in WordB, then proceed With next.π If a letter is not found, Words are not anagrams ; if all areπ found, Words are anagrams. }π{ Registers usage :π AL : scratch For SCASπ AH : unusedπ BX : offset part of WordC's addressπ CX : will be used as a counter For SCASπ DL : contains length of Strings ; 'll be used to reset CXπ DH : loop counter ; initially =DLπ ES : segment part of WordC's addressπ DI : scratch For SCASπ DS:SI : Pointer to next Char to process in WordAπ}π@Bcle:π LodSB { Load next Char of WordA in AL }π Mov CL, DL { Load length of String in CX }π Mov DI, BX { Copy offset of WordC to DI }π RepNE ScaSB { Scan WordC For AL 'till found }π JNE @NotAng { Char not found, not anagrams }π Dec DI { Back-up to matching Char }π Mov Byte Ptr ES:[DI], '*' { Mark the Character as 'used' }π Dec DH { Dec loop counter }π Or DH, DH { Done all Chars ? }π JNZ @Bcle { No, loop }ππ { All Chars done, the Words are anagrams }π Mov AL, 1 { Result=True }π Or AL, AL { Set accordingly the ZF }π Jmp @Doneπ@NotAng:π XOr AL, AL { Result=False }π@Done:π Pop DS { Restore DS }πend ;ππFunction ReadWordsFrom(FName : String) : Boolean ;πVar InF : Text ; { Input File }π Buf : Array[1..2048] Of Byte ; { Speed-up Text buffer }π Lig : String ; { Read line }π Wrd : String ; { Word gotten from parsed Lig }π WSt : TWordString ; { Checked version of Wrd }π p : Integer ; { Work }π Cnt : LongInt ; { Line counter }πbeginπ ReadWordsFrom:=False ; { 'till now, at least ! }π WordsList:=New(PWordCollection, Init(20, 20)) ;π Assign(InF, FName) ;π {$i-}π ReSet(InF) ;π {$i+}π If IOResult<>0 Then Exit ;π SetTextBuf(InF, Buf, SizeOf(Buf)) ;π Cnt:=0 ;ππ While Not EOF(InF) Doπ beginπ Inc(Cnt) ;π ReadLn(InF, Lig) ;π While Lig<>'' Doπ beginπ { Let's parse the read line into Words }π p:=Pos(',', Lig) ;π If p=0 Then p:=Length(Lig)+1 ;π Wrd:=Copy(Lig, 1, p-1) ;π { Check of overflowing Word length }π If Length(Wrd)>MaxWordLen Thenπ WriteLn('Word length > ', MaxWordLen, ' : ', Wrd) ;π WSt:=Wrd ;π CleanUp(WSt) ;π If WSt<>'' Then WordsList^.Insert(New(PWord, Init(WSt))) ;π Delete(Lig, 1, p) ;π end ;π end ;π {$i-}π Close(InF) ;π {$i+}π If IOResult<>0 Then ;π ReadWordsFrom:=True ;ππ WriteLn(Cnt, ' lines, ', WordsList^.Count, ' Words found.') ;πend ;ππProcedure CheckAnagrams(i : Integer) ;π{ This Procedure builds, if necessary (i.e. not already done), the anagramsπ list For Word #i of the list. }πVar Org : PWord ; { Original Word (1st of list) }π j : Integer ; { Work }π Last : PWord ; { Last anagram found }πbeginπ Org:=WordsList^.Items^[i] ;π If Org^.FirstAng<>Nil Thenπ beginπ { This Word is already known to be the anagram of at least anotherπ one ; don't re-do the job. }π { _or_ this Word is known to have no anagrams in the list }π Exit ;π end ;ππ { Search anagrams }π Last:=Org ;π Org^.FirstAng:=Org ; { This Word is the first of it's }π { own anagrams list ; normal, no ? }π For j:=Succ(i) To Pred(WordsList^.Count) Doπ { Don't search the begining of the list, of course ! }π beginπ { Let's skip anagram checking if lengths are <> }π If Org^.It[0]=PWord(WordsList^.Items^[j])^.It[0] Thenπ If AreAnagrams(Org^.It, PWord(WordsList^.Items^[j])^.It) Thenπ beginπ { Build chained list of anagrams }π Last^.NextAng:=WordsList^.Items^[j] ;π Last:=WordsList^.Items^[j] ;π Last^.FirstAng:=Org ;π end ;π end ;π Last^.NextAng:=Nil ; { Unusefull, but keep carefull }πend ;ππProcedure ScanForAnagrams ;π{ This Procedure scans the list of Words For anagrams, and do the outputingπ to the 'ANAGRAM.RES' File. }ππVar i : Integer ; { Work }π Tmp : PWord ; { Temporary Word }π Out : Text ; { Output File }π Comma : Boolean ; { Helps dealing With commas }π Current : PWord ; { Currently handled Word }πbeginπ Assign(Out, OutFileName) ;π ReWrite(Out) ;ππ With WordsList^ Doπ For i:=0 To Pred(Count) Doπ beginπ Current:=Items^[i] ;π CheckAnagrams(i) ;π { We're now gonna scan the chained list of known anagrams forπ this Word. }π If (Current^.NextAng<>Nil) Or (Current^.FirstAng<>Current) Thenπ { This Word has at least an anagram other than itself }π beginπ Write(Out, PadStr(Current^.It, 12)) ;π Inc(CntAnagrams) ;π Comma:=False ;π Tmp:=Current^.FirstAng ;π While Tmp<>Nil Doπ beginπ If Tmp<>Current Then { Don't reWrite it... }π beginπ If Comma Then Write(Out, ', ') ;π Comma:=True ;π Write(Out, Tmp^.It) ;π Inc(CntAnagrams) ;π end ;π Tmp:=Tmp^.NextAng ;π end ;π WriteLn(Out) ;π end ;π end ;ππ Close(Out) ;πend ;ππVar Tmp : LongInt ;ππbeginπ { Check command line parameter }ππ If ParamCount<>1 Thenπ beginπ WriteLn('Anagram. Raphaël Vanney, 01/93 - Anagram''s contest entry.');π WriteLn ;π WriteLn('Anagram <input_File>') ;π WriteLn ;π WriteLn('Please specify input File name.') ;π Halt(1) ;π end ;ππ OrgMem:=MemAvail ;ππ { Read Words list from input File }ππ If Not ReadWordsFrom(ParamStr(1)) Thenπ beginπ WriteLn('Error reading Words from input File.') ;π Halt(1) ;π end ;ππ { Display statistics stuff }ππ WriteLn('Reading and sorting done.') ;π UsedMem:=OrgMem-MemAvail ;π WriteLn('Used RAM : ', UsedMem, ' Bytes') ;π Tmp := Trunc(1.0 * MemAvail / (1.0 * UsedMem / WordsList^.Count)) ;π If Tmp > 16383 Thenπ Tmp := 16383 ;π WriteLn('Potential Words manageable : ', Tmp) ;ππ { Scan For anagrams, create output File }ππ ScanForAnagrams ;π WriteLn('Anagrams scanning & output done.') ;π WriteLn(CntAnagrams, ' Words written to ', OutFileName) ;ππ { Clean-up }π Dispose(WordsList, Done) ;πend.π{ππ------------------------------------------------------------------------------ππOkay, this is my entry For the 'anagram contest' !ππThe few things I'd like to point-out about it :ππ. I chosed to use OOP, in contrast to seeking speed. I wouldn't say myπ Program is Really slow (7.25 secs on my 386-33), but speed was not myπ first concern.π. It fully Uses one of the interresting points of OOP in TP, i.e.π reusability, through inheritance,π. When a Word (A) has been found to be an anagram of another (B), theπ Program never searches again For the anagrams of (A) ; thisπ highly reduces computing time... but I believe anybody does the same.π. I also quite like the assembly langage Function 'AreAnagrams'.ππ------------------------------------------------------------------------------ππThe Words list is stored in memory in the following maner :π. A collection (say, a list) of the Words,π. Within this list, anagrams are chained as a listπ. Each Word knows the first and the next of its anagramsππ------------------------------------------------------------------------------ππFor the sake of speed, I did something I'm quite ashamed of ; but itπsaves 32% of execution time, so...πThe usual way to access element #i of a TCollection is to call Function Atπwith parameter i (i.e. At(i)) ; there is also another way, which is not Reallyπclean, but which I chosed to use : access it directly through Items^[i].π 4 05-28-9313:57ALL SWAG SUPPORT TEAM BUBBLE1.PAS IMPORT 6 {π> Does anyone know of a routine or code that would allow For aπ> alphabetical sort?ππDepends on what Type of sorting you want to do- For a very small list, aπsimple BubbleSort will suffice.π}πConstπ max = 50;πVarπ i,j:Integer;π a : Array[1..max] of String;π temp : String;πbeginπ For i := 1 to 50 doπ For j := 1 to 50 doπ if a[i] < a[j] thenπ beginπ temp := a[i];π a[i] := a[j];π a[j] := temp;π end; { if }πend.ππ{πIf it's a bigger list than, say 100 or so elements, or it needs to beπsorted often, you'll probably need a better algorithm, like a shell sortπor a quicksort.π}ππ 5 05-28-9313:57ALL SWAG SUPPORT TEAM BUBBLE2.PAS IMPORT 8 {π> Does anyone know of a routine or code that would allow forπ> a alphbetical sort in pascal? If so could you mail orπ> Write it in this base? Thanks!ππI know of a couple but this is the best and fastest one that I know ofππBubble Sortπ}ππTypeπ StArray = Array [1..10] of String;ππProcedure bubble_sort(Var names : StArray);πVarπ i,π last,π latest : Integer;π temp : String;π exchanged : Boolean;πbeginπ last := max_names - 1;π Repeatπ i := 1;π exchanged := False;π latest := last;π Repeatπ if names[i] > names[i+1] thenπ beginπ temp := names[i];π names[i] := names[i+1];π names[i+1] := temp;π exchanged := True;π latest := i;π end;π inc(i);π Until not (i <= last);π last := latest;π Until not ((last >= 2) and exchanged);πend;π 6 05-28-9313:57ALL SWAG SUPPORT TEAM COMB1.PAS IMPORT 11 {π>Has anyone successfully converted the Combsort algorithm (I think it wasπ>published in DDJ or Byte about two years ago) from C to Pascal? I'veπ>lost the original C source For this, but if anyone has any info, I wouldπ>appreciate it.π}ππProgram TestCombSort; { Byte magazine, April '91 page 315ff }πConstπ Size = 25;πTypeπ SortType = Integer;πVarπ A: Array [1..size] of SortType;π i: Word;ππProcedure CombSort (Var Ain);πVarπ A: Array [1..Size] of SortType Absolute Ain;π Switch: Boolean;π i, j, Gap: Word;π Hold: SortType;πbeginπ Gap := Size;π Repeatπ Gap := Trunc (Gap / 1.3);π if Gap < 1 thenπ Gap := 1;π Switch := False;π For i := 1 to Size - Gap doπ beginπ j := i + Gap;π if A [i] > A [j] then { swap }π beginπ Hold := A [i];π A [i] := A [j];π A [j] := Hold;π Switch := True;;π end;π end;π Until (Gap = 1) and not Switch;πend;ππbeginπ Randomize;π For i := 1 to Size doπ A [i] := Random (32767);π WriteLn;π WriteLn ('Unsorted:');π For i := 1 to Size doπ Write (A [i]:8);π WriteLn;π CombSort (A);π WriteLn ('Sorted:');π For i := 1 to Size doπ Write (A [i]:8);π WriteLn;πend.π 7 05-28-9313:57ALL SWAG SUPPORT TEAM COUNT1.PAS IMPORT 16 {π ...Well, as Greg Vigneault reminded me, there is a much fasterπ method of sorting this sort of data called a "Count" sort. Iπ often overlook this method, as it doesn't appear to be a sortπ at all at first glance:π}πProgram Count_Sort_Demo;ππConstπ co_MaxItem = 200;ππTypeπ byar_MaxItem = Array[1..co_MaxItem] of Byte;π byar_256 = Array[0..255] of Byte;ππVarπ by_Index : Byte;π wo_Index : Word;π DataBuffer : byar_MaxItem;π SortTable : byar_256;ππbeginπ (* Initialize the pseudo-random number generator. *)π randomize;ππ (* Clear the CountSort table. *)π fillChar(SortTable, sizeof(SortTable), 0);ππ (* Create random Byte data. *)π For wo_Index := 1 to co_MaxItem doπ DataBuffer[wo_Index] := random(256);ππ (* Display random data. *)π Writeln;π Writeln('RANDOM Byte DATA');π For wo_Index := 1 to co_MaxItem doπ Write(DataBuffer[wo_Index]:4);ππ (* CountSort the random data. *)π For wo_Index := 1 to co_MaxItem doπ inc(SortTable[DataBuffer[wo_Index]]);ππ (* Display the CountSorted data. *)π Writeln;π Writeln('COUNTSORTED Byte DATA');π For by_Index := 0 to 255 doπ if (SortTable[by_Index] > 0) thenπ For wo_Index := 1 to SortTable[by_Index] doπ Write(by_Index:4)πend.π{π ...This Type of sort is EXTEMELY fast, even when compared toπ QuickSort, as there is so little data manipulation being done.ππ>BTW, why are there so many different sorting methods?π>Quick, bubble, Radix.. etc, etcππ ...Because, Not all data is created equally.π (ie: Some Types of sorts perform well on data that is veryπ random, While other Types of sorts perform well on dataπ that is "semi-sorted" or "almost sorted".)ππ} 8 05-28-9313:57ALL SWAG SUPPORT TEAM COUNT2.PAS IMPORT 34 {π>I'm in need of a FAST way of finding the largest and the smallestπ>30 numbers out of about 1000 different numbers.π> ...Assuming that the 1000 numbers are in random-order, I imagineπ> that the simplest (perhaps fastest too) method would be to:π> 1- Read the numbers in an Array.π> 2- QuickSort the Array.π> 3- First 30 and last 30 of Array are the numbers you want.π> ...Here's a QuickSort demo Program that should help you With theπ> sort: ...ππ Stop the presses, stop the presses!ππ Remember the recent Integer sort contest, on the Intelec Programmingπ conference? The fastest method was a "counting" sort technique, whichπ used the Integers (to be sorted) as indexes of an Array.ππ You asked John Kuhn how it worked, as his example code was in messyπ C. I sent you an explanation, along With example TP source. Aroundπ that time my link to Intelec was intermittently broken; I didn'tπ hear back from you - so you may not have received my message (datedπ Jan.02.1993). I hope you won't mind if I re-post it here and now...ππ In a message With John Kuhn...π> Simply toggle the sign bit of the values beFore sorting. Everythingπ> falls into place appropriately from there.π> ...OK, but how about toggling them back to their originalπ> state AFTER sorting? (I want to maintain negative numbers)π> How can you tell which data elements are negative numbers???ππ Hi Guy,ππ if you've got all of this under your belt, then please disregardπ the following explanation ...ππ By toggling the high bit, the Integers are changed in a way that,π conveniently, allows sorting by magnitude: from the "most negative"π to "most positive," left to right, using an Array With unsignedπ indexes numbering 0...FFFFh. The Array size represents the numberπ of all possible (16-bit) Integers... -32768 to 32767.ππ The "Count Sort" involves taking an Integer, toggling its high bitπ (whether the Integer is originally positive or negative), thenπ using this tweaked value as an index into the Array. The tweakedπ value is used only as an Array index (it becomes an unsignedπ index somewhere within 0..FFFFh, inclusive).ππ The Array elements, which are initialized to zero, are simply theπ counts of the _occurrences_ of each Integer. The original Integers,π With proper sign, are _derived_ from the indexes which point toπ non-zero elements (after the "sort")... ie. an original Integer isπ derived by toggling the high bit of a non-zero element's index.ππ Array elements of zero indicate that no Integer of the correspondingπ (derived) value was encountered, and can be ignored. if any elementπ is non-zero, its index is used to derive the original Integer. ifπ an Array element is greater than one (1), then the correspondingπ Integer occurred more than once.ππ A picture is worth 1000 Words: The following simplified exampleπ sorts some negative Integers. The entire Count Sort is done byπ a Single For-do-inC() loop - hence its speed. The xors do theπ required high-bit toggling ...π}πππProgram DemoCountSort; { Turbo Pascal Count Sort. G.Vigneault }ππ{ some negative Integers to sort ... }πConstπ SomeNegs : Array [0..20] of Integer =π (-2,-18,-18,-20000,-100,-10,-8,-11,-5,π -1300,-17,-1,-16000,-4,-12,-15,-19,-1,π -31234,-6,-7000 );ππ{ pick an Array to acComplish Count Sort ... }πVarπ NegNumArray : Array [$0000..$7FFF] of Byte;π{ PosNumArray : Array [$8000..$FFFF] of Byte; }π{ AllNumArray : Array [$0000..$FFFF] of Byte; use heap }π Index : Word;π IntCount : Byte;ππbeginπ { Initialize }π FillChar( NegNumArray, Sizeof(NegNumArray), 0 );ππ { Count Sort (the inC does this) ... }ππ For Index := 0 to 20 doπ { Just 21 negative Integers to sort }π inC( NegNumArray[ Word(SomeNegs[Index] xor $8000) ]);ππ { then display the sorted Integers ... }π For Index := 0 to $7FFF doπ { Check each Array element }π For IntCount:= 1 to NegNumArray[Index] doπ { For multiples }π WriteLn( Integer(Index xor $8000) ); { derive value }ππend { DemoCountSort }.π 9 05-28-9313:57ALL SWAG SUPPORT TEAM ELEVATR1.PAS IMPORT 15 {π> Thanks For the code... It worked great! BTW, why are there so manyπ> different sorting methods? Quick, bubble, Radix.. etc, etcππYes, there are lots of sorting algorithms out there! I also found this outπthe hard way! :-) A couple of years ago, I only knew the so-called "bubble"πsort, and decided to create my own sorting algorithm. It would have to beπfaster than bubble, yet remaining small, simple, and not memory hungry.πand I did it, but only to find out a few weeks later that there were muchπbetter sorts than the one I created... But it sure was great fun beatingπbubble! (which is brain-dead anyway! ;-)ππSo here it is, my two cents to the history of sorting algorithms, theπamazing, blazingly fast (*)... ELEVAtoR SorT!... Why ELEVAtoR??, you ask inπunison! Because it keeps going up & down! :-)π}ππProgram mysort;ππUses Crt;ππConstπ max = 1000;ππTypeπ list = Array[1..max] of Word;ππVarπ data : list;π dummy : Word;πππProcedure elevatorsort(Var a: list; hi: Word);ππVarπ lo,π peak,π temp,π temp2 : Word;ππbeginπ peak := 1;π lo := 1;π Repeatπ temp := a[lo];π temp2 := a[lo + 1];π if temp > temp2 thenπ beginπ a[lo] := temp2;π a[lo + 1] := temp;π if lo <> 1 then dec(lo);π endπ elseπ beginπ inc(peak);π lo:=peak;π end;π Until lo = hi;πend;πππbeginπ ClrScr;π Writeln('Generating ', max ,' random numbers...');π randomize;π For dummy:=1 to max do data[dummy]:=random(65535);π Writeln('Sorting random numbers...');π elevatorsort(data,max);π For dummy:=1 to max do Write(data[dummy]:5,' ');πend.ππ{π(*) it's speed lies somewhere between "BUBBLE" and "inSERT"; it's muchπfaster than "BUBBLE", and a little slower than "inSERT"... :-)π}π 10 05-28-9313:57ALL SWAG SUPPORT TEAM ELEVATR2.PAS IMPORT 11 {π>Why can't Borland come out With a Universal sort since they made theπ>Program.. <G>ππI guess there's no such thing as a "universal" sort... There are a few veryπgood sorting algorithms, and depending on some factors, you just have toπchoose the one that best fits your needs!ππHere's an update to my ELEVAtoR sort, this one's even faster!π}ππProgram mysort;ππUses Crt;ππConstπ max = 1000;ππTypeπ list = Array[1..max] of Word;ππVarπ data : list;π dummy : Word;πππProcedure elevatorsort(Var a: list; hi: Word);ππVarπ dummy,π low,π peak,π temp,π temp2 : Word;ππbeginπ peak := 1;π low := 1;π temp2 := a[low + 1];π Repeatπ temp := a[low];π if temp > temp2 thenπ beginπ a[low] := temp2;π a[low + 1] := temp;π if low <> 1 then dec(low);π endπ elseπ beginπ inc(peak);π low:=peak;π if low <> hi then temp2:=a[low + 1];π end;π Until low = hi;πend;ππbeginπ ClrScr;π Writeln('Generating ', max ,' random numbers...');π randomize;π For dummy:=1 to max do data[dummy]:=random(65535);π Writeln('Sorting random numbers...');π elevatorsort(data,max);π For dummy:=1 to max do Write(data[dummy]:5,' ');πend.π 11 05-28-9313:57ALL SWAG SUPPORT TEAM IMROVSRT.PAS IMPORT 20 {πMARK OUELLETππ> I code these things this way:π>π> for I := 1 to MAX-1 doπ> for J := I+1 to MAX doπ> if A[I] < A[J] thenπ> beginπ> ( swap code )π> endππ this can be improved even more. By limiting the MAX value on eachπsuccessive loop by keeping track of the highest swaped pair.ππ If on a particular loop, no swap is performed from element MAX-10πonto the end. Then the next loop does not need to go anyhigher thanπMAX-11. Remember you are moving the highest value up, if no swap isπperformed from MAX-10 on, it means all values above MAX-11 are in orderπand all values below MAX-10 are smaller than MAX-10.π}ππ{$X+}πprogram MKOSort;ππUSESπ Crt;ππConstπ MAX = 1000;ππvarπ A : Array[1..MAX] of word;π Loops : word;ππprocedure Swap(Var A1, A2 : word);πvarπ Temp : word;πbeginπ Temp := A1;π A1 := A2;π A2 := Temp;πend;ππprocedure working;πconstπ cursor : array[0..3] of char = '\|/-';π CurrentCursor : byte = 1;π Update : word = 0;πbeginπ update := (update + 1) mod 2500;π if update = 0 thenπ beginπ DirectVideo := False;π write(Cursor[CurrentCursor], #13);π CurrentCursor := ((CurrentCursor + 1) mod 4);π DirectVideo := true;π end;πend;ππprocedure Bubble;πvarπ Highest,π Limit, I : word;π NotSwaped : boolean;πbeginπ Limit := MAX;π Loops := 0;π repeatπ I := 1;π Highest := 2;π NotSwaped := true;π repeatπ working;π if A[I] > A[I + 1] thenπ beginπ Highest := I;π NotSwaped := False;π Swap(A[I], A[I + 1]);π end;π Inc(I);π until (I = Limit);π Limit := Highest;π Inc(Loops);π until (NotSwaped) or (Limit <= 2);πend;ππprocedure InitArray;πvarπ I, J : word;π Temp : word;πbeginπ randomize;π for I := 1 to MAX doπ A[I] := I;π for I := MAX - 1 downto 1 doπ beginπ J := random(I) + 1;π Swap(A[I + 1], A[J]);π end;πend;ππprocedure Pause;πbeginπ writeln;π writeln('Press any key to continue...');π while keypressed doπ readkey;π while not keypressed do;π readkey;πend;ππprocedure PrintOut;πvarπ I : word;πbeginπ ClrScr;π For I := 1 to MAX doπ beginπ if WhereY >= 22 thenπ beginπ Pause;π ClrScr;π end;π if (WhereX >= 70) thenπ Writeln(A[I] : 5)π elseπ Write(A[I] : 5);π end;π writeln;π Pause;πend;ππbeginπ ClrScr;π InitArray;π PrintOut;π Bubble;π PrintOut;π writeln;π writeln('Took ', Loops, ' Loops to complete');πend.π 12 05-28-9313:57ALL SWAG SUPPORT TEAM MODHEAP.PAS IMPORT 39 {πOk, here is your "fastest sort routine." I spent a couple hours just tweakingπand testing to make sure that it was performing 100%.ππAdding $G+ only yielded a very slight speed increase but a noticeable one. (Theπspeed results below are based on $G-.) Using anything other than Integer forπVariables caused a slight degredation in performance. I would guess thatπInteger arithmetic is where Borland focused its optimizations on. Word andπLongInt all caused performance degredation.ππAND, it used to be that previous to v6 or v5.5 that multiplication was a bottleπneck too, as in J := I * 3; The faster method was to say J := I+I+I; sinceπaddition is faster than multiplication. I didn't see any appreciable differenceπwith respect to multiplication over addition here.ππThe following algorithm is a modified Fibonacci Heap sort With the addition ofπa mid-sort bounce technique. It runs almost twice the speed of the Quick Sortπalgorithm as posted in my last message.ππIt Uses considerably less stack then Quick Sort since it is non-recursive. And,πfor those of you who hate GOTO's, there's three in this code. Any other way Iπcould think of would increase data and reduce performance. But you're certainlyπwelcome to jump in and knock 'em outa there if you can!ππHere are the speed results as tested on 386-40mhz:ππ 500 Elements - (Less than 1/10 second)π 1000 Elements - 0.1 Secondsπ 1500 Elements - 0.2 Secondsπ 2000 Elements - 0.3 Secondsπ 5000 Elements - 1.0 Secondsπ 7500 Elements - 1.7 Secondsπ 10000 Elements - 2.3 SecondsππI modified the skeleton Program slightly to increase the number of 10 CharacterπStrings to 10,000 so that I could test that far.ππHere is the source code For the algorithm. Just "Plug" it into the skeletonπProgram I posted a day or so ago.ππ{------------------------------------------------------------------------}πProcedure ModHeapSort( Total : Integer );πVarπ I,J,K,L : Integer;π X, Temp : Pointer;π M,M1,M2 : Integer;ππ Label JumpOut;π Label Terminate;π Label SmallSort;ππbeginπ if Total <= 4 Thenπ Goto SmallSort; { Too small For Split sorting }ππ M := Pred(Total) div 3;π M1 := ( M * 3 ) + 2;ππ if M1 <= Total Thenπ beginπ if M1 < Total Thenπ if SortArray[M1]^ < SortArray[Total]^ Thenπ M2 := Totalπ ELSEπ M2 := M1π ELSEπ M2 := M1;ππ if SortArray[1]^ < SortArray[M2]^ Thenπ begin { Swap first element to M2 }π Temp := SortArray[1];π SortArray[1] := SortArray[M2];π SortArray[M2] := Temp;π end;ππ end; {IF M1 <= Total}ππ For L := M DownTo 1 DOπ beginπ X := SortArray[L];π I := L;π J := I * 3;ππ Repeatππ K := Pred(J);ππ if SortArray[K]^ < SortArray[J]^ Thenπ K := J;π if SortArray[K]^ < SortArray[Succ(J)]^ Thenπ K := Succ(J);ππ SortArray[I] := SortArray[K];π I := K;π J := I * 3;ππ Until J > M1;ππ J := Succ(I) div 3;ππ Repeatππ if SortArray[J]^ >= SmallArrPtr(X)^ Thenπ Goto JumpOut;ππ SortArray[I] := SortArray[J];π I := J;π J := Succ(J) div 3;ππ Until J < L;ππ JumpOut:π SortArray[I] := X;ππ end;ππ For L := M1 To Total DOπ beginπ X := SortArray[L];π I := L;π J := Succ(I) div 3;ππ if SortArray[J]^ < SmallArrPtr(X)^ Thenπ beginππ Repeatπ SortArray[I] := SortArray[J];π I := J;π J := Succ(J) div 3;π Until SortArray[J]^ >= SmallArrPtr(X)^;ππ SortArray[I] := X;ππ end; {IF}π end; {For}ππ L := Total;ππ While L > 4 DOπ beginπ X := SortArray[L];π SortArray[L] := SortArray[1];π Dec(L,1);π I := 1;π J := 3;ππ Repeatπ K := Pred(J);ππ if SortArray[K]^ < SortArray[J]^ Thenπ K := J;π if SortArray[K]^ < SortArray[Succ(J)]^ Thenπ K := Succ(J);ππ SortArray[I] := SortArray[K];π I := K;π J := I * 3;π Until J >= L;ππ Dec(J,1);ππ if J <= L Thenπ beginπ if J < L Thenπ if SortArray[J]^ < SortArray[L]^ Thenπ J := L;π SortArray[I] := SortArray[J];π I := J;π end; {IF}ππ J := Succ(I) div 3;ππ if SortArray[J]^ < SmallArrPtr(X)^ Thenπ Repeatπ SortArray[I] := SortArray[J];π I := J;π J := Succ(J) div 3;π Until SortArray[J]^ >= SmallArrPtr(X)^;ππ SortArray[I] := X;π end;ππ { Process last four remaining elements, or less than 4 to sort }π { Use "Insertion sort" method For best linear time performance }ππ SmallSort :π if Total <= 4 Thenπ L := Totalπ ELSEπ L := 4;ππ For I := 2 To L DOπ beginπ X := SortArray[I];π For J := Pred(I) DownTo 1 DOπ if SortArray[J]^ > SmallArrPtr(X)^ Thenπ SortArray[Succ(J)] := SortArray[J]π ELSEπ Goto Terminate;π J := 0;ππ Terminate : SortArray[Succ(J)] := X;ππ end; {For I}πend;π 13 05-28-9313:57ALL SWAG SUPPORT TEAM OOP-SORT.PAS IMPORT 10 {πWL> Say, would anyone know how-to sort a Record With 5 thingπ WL> in it one of which is "NAME"...I want to sort each Recordπ WL> in the Array by name and can't figure it out....my Arrayπ WL> name is LabelS and my Record name is SofT....so any helpπ WL> would greatly be appreciated...thanksππThe easiest way is to make it an Object, and put it in a TSortedCollection.πFor example:π}ππ Typeπ PMyrec = ^TMyrec;π TMyrec = Object(tObject)π name : String;π other : Integer;π end;ππ TSortedRecs = Object(TSortedCollection)π Function Compare(Key1,key2:Pointer):Integer; Virtual;π end;ππ Function TSortedRecs.Compare;π Varπ p1 : PMyrec Absolute Key1;π p2 : PMyrec Absolute Key2;π beginπ if p1^.name < p2^.name thenπ Compare := -1π else if p1^.name = p2^.name thenπ Compare := 0π elseπ Compare := 1;π end;ππVarπ rec : PMyrec;π coll: TSortedRecs; beginπ coll.init(100,10); { Init to 100 Records, grow by 10s }ππ While More_Records doπ beginπ new(rec,init);π rec^.name := Get_Name;π rec^.other:= Get_Other;π coll.insert(rec);π end;π 14 05-28-9313:57ALL SWAG SUPPORT TEAM PNTRSORT.PAS IMPORT 28 {πREYNIR STEFANSSONππSome time ago I wangled myself into a beta testing team For a floppyπdisk catalogger called FlopiCat. This is a rather BASIC (in more than oneπway) Program, but works well enough.ππThe built-in sorting routine was a bit quacked, so I wrote my ownπexternal sorter, which is both more versatile and faster (by far) than theπinternal one.ππ Here it is, in Case someone can use the idea (and code):π}ππProgram FlopiSrt; { Sorts FlopiCat.Dat. }ππConstπ Maximum = 6000; { I don't need that many meself... }π FName : String[12] = 'Flopicat.Dat';ππTypeπ fEntry = Recordπ n : Array[1..4] of Char;π i : Array[1..35] of Char;π d : Array[1..39] of Char;π end;ππ En1 = Array[1..78] of Char;π En2 = Recordπ n : Array[1..4] of Char;π f : Array[1..9] of Char;π e : Array[1..3] of Char;π z : Array[1..8] of Char;π t : Array[1..15] of Char;π d : Array[1..39] of Char;π end;ππ En3 = Recordπ f, d : Array[1..39] of Char;π end;ππ pEntry = ^fEntry;ππVarπ Entry : Array [1..Maximum] of pEntry;π fc : File of fEntry;π Rev : Boolean;π LoMem : Pointer;π i,π NumOfEntries : Integer;π nfd : Char;π s : String;ππFunction ToSwap(i, j : Integer) : Boolean;πVarπ Swop : Boolean;πbeginπ Swop := False;π Case nfd OFπ { Sorting by disk number: }π 'N' : if Entry[i]^.n > Entry[j]^.n thenπ Swop := True;π { Sorting by File information: }π 'I' : if Entry[i]^.i > Entry[j]^.i thenπ Swop := True;π { Sorting by description: }π 'D' : if Entry[i]^.d > Entry[j]^.d thenπ Swop := True;π { Sorting by all the String: }π 'A' : if En1(Entry[i]^) > En1(Entry[j]^) thenπ Swop := True;π { Sorting by File name only: }π 'F' : if En2(Entry[i]^).f > En2(Entry[j]^).f thenπ Swop := True;π { Sorting by File extension only: }π 'E' : if En2(Entry[i]^).e > En2(Entry[j]^).e thenπ Swop := True;π { Sorting by File size: }π 'Z' : if En2(Entry[i]^).z > En2(Entry[j]^).z thenπ Swop := True;π { Sorting by date/time stamp: }π 'T' : if En2(Entry[i]^).t > En2(Entry[j]^).t thenπ Swop := True;π { Sorting by disk number/File info block: }π 'B' : if En3(Entry[i]^).f > En3(Entry[j]^).f thenπ Swop := True;π end;π ToSwap := Swop xor Rev;πend;ππ{ if I remember correctly, I settled on using shaker/shuttle sort. }πProcedure SortIt;πVarπ i, j,π pb, pf,π pp, pt : Integer;π t : pEntry;ππ Procedure SwapIt(i, j : Integer);π beginπ t := Entry[i];π Entry[i] := Entry[j];π Entry[j] := t;π end;ππbeginπ Write('0 entries processed.');π i := 0;π pt := 2;π pb := NumOfEntries;π pf := 0;π Repeatπ pp := pt;π Repeatπ if ToSwap(pp - 1, pp) thenπ beginπ SwapIt(pp - 1, pp);π pf := pp;π end;π Inc(pp);π Until pp > pb;ππ pb := pf - 1;π j := i;π i := NumOfEntries - (pb - pt + 2);π if (i MOD 10) < (j MOD 10) thenπ Write(#13, i);π if pb < pt thenπ Exit;π pp := pb;ππ Repeatπ if ToSwap(pp - 1, pp) thenπ beginπ SwapIt(pp - 1, pp);π pf := pp;π end;π Dec(pp);π Until pp < pt;ππ pt := pf + 1;π j := i;π i := NumOfEntries - (pb - pt + 2);π if (i MOD 10) < (j MOD 10) thenπ Write(#13, i);π Until pb < pt;πend;ππ 15 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK1.PAS IMPORT 15 Unit Qsort;ππ{ππCopyright 1990 Trevor J CarlsenπAll rights reserved.ππAuthor: Trevor J Carlsenπ PO Box 568π Port Hedland WA 6721π πA general purpose sorting Unit.πππ}ππInterfaceππTypeπ updown = (ascending,descending);π str255 = String;π dataType = str255; { the Type of data to be sorted }π dataptr = ^dataType;π ptrArray = Array[1..10000] of dataptr;π Arrayptr = ^ptrArray;π πConst π maxsize : Word = 10000;π SortType : updown = ascending;π πProcedure QuickSort(Var da; left,right : Word);ππ{============================================================================}πImplementationπ πProcedure swap(Var a,b : dataptr); { Swap the Pointers }π Var t : dataptr;π beginπ t := a;π a := b;π b := t;π end;π π πProcedure QuickSort(Var da; left,right : Word);π Varπ d : ptrArray Absolute da;π pivot : dataType;π lower,π upper,π middle : Word;ππ beginπ lower := left;π upper := right;π middle:= (left + right) div 2;π pivot := d[middle]^;π Repeatπ Case SortType ofπ ascending : beginπ While d[lower]^ < pivot do inc(lower);π While pivot < d[upper]^ do dec(upper);π end;π descending: beginπ While d[lower]^ > pivot do inc(lower);π While pivot > d[upper]^ do dec(upper);π end;π end; { Case } π if lower <= upper then beginπ { swap the Pointers not the data }π swap(d[lower],d[upper]);π inc(lower);π dec(upper);π end;π Until lower > upper;π if left < upper then QuickSort(d,left,upper);π if lower < right then QuickSort(d,lower,right);π end; { QuickSort }ππend.πππ 16 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK2.PAS IMPORT 16 {...This is as generic a QuickSort as I currently use:π}π{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,R-,S-,T-,V-}π{$M 60000,0,0}ππProgram QuickSortDemo;πUsesπ Crt;ππConstπ coMaxItem = 30000;ππTypeπ Item = Word;π arItem = Array[1..coMaxItem] of Item;ππ (***** QuickSort routine. *)π (* *)πProcedure QuickSort({update} Var arData : arItem;π {input } woLeft,π woRight : Word);πVarπ Pivot,π TempItem : Item;π woIndex1,π woIndex2 : Word;πbeginπ woIndex1 := woLeft;π woIndex2 := woRight;π Pivot := arData[(woLeft + woRight) div 2];π Repeatπ While (arData[woIndex1] < Pivot) doπ inc(woIndex1);π While (Pivot < arData[woIndex2]) doπ dec(woIndex2);π if (woIndex1 <= woIndex2) thenπ beginπ TempItem := arData[woIndex1];π arData[woIndex1] := arData[woIndex2];π arData[woIndex2] := TempItem;π inc(woIndex1);π dec(woIndex2)π endπ Until (woIndex1 > woIndex2);π if (woLeft < woIndex2) thenπ QuickSort(arData, woLeft, woIndex2);π if (woIndex1 < woRight) thenπ QuickSort(arData, woIndex1, woRight)πend; (* QuickSort. *)ππVarπ woIndex : Word;π Buffer : arItem;ππbeginπ Write('Creating ', coMaxItem, ' random numbers... ');π For woIndex := 1 to coMaxItem doπ Buffer[woIndex] := random(65535);π Writeln('Finished!');π Write('Sorting ', coMaxItem, ' random numbers... ');π QuickSort(Buffer, 1, coMaxItem);π Writeln('Finished!');π Writeln;π Writeln('Press the <ENTER> key to display all ', coMaxItem,π ' sorted numbers...');π readln;π For woIndex := 1 to coMaxItem doπ Write(Buffer[woIndex]:8)πend.π 17 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK3.PAS IMPORT 13 { File that will teach me how to quick sort? I know how quick sort worksπ but I don't know why my Program doesn't sort properaly. Sometimes it goesπ through one cycle of sort and sometimes it goes through two cycles of sortπ but it never sorts it Completely! Tek ChanππHere is some generic source code, change it to suit your needs/Types:π}ππProcedure Split(Var Info: ArrayType; First: Integer; Last: Integer; VarπSplitPt1: Integer; Var SplitPt2: Integer);ππVar SplitVal, Temp: ArrayElementType;ππbeginπ SplitVal:=Info[(First+Last) div 2];π Repeatπ While Info[First] < SplitVal doπ First:=First+1;π While Info[Last] > SplitVal doπ Last:=Last-1;π if First <= Last thenπ beginπ Temp:=Info[First];π Info[First]:=Info[Last];π Info[Last]:=Temp;π First:=First+1;π Last:=Last-1;π endπ Until First > Last;π SplitPt1:=First;π SplitPt2:=Last;πend;ππProcedure QuickSort(Var Info: ArrayType; First:Integer; Last: Integer);ππVar SplitPt1, SplitPt2: Integer;ππbeginπ if First < Last thenπ beginπ Split(Info, First, Last, SplitPt1, SplitPt2);π if SplitPt1 < Lastπ then QuickSort(Info, SplitPt1, Last);π if First < SplitPt2π then QuickSort(Info, First, SplitPt2);π endπend;ππ{πThis is a -very- fast sort, much faster than any other I have. Does aπnon-recursive version exist? Are there any faster sorts? Brianπ} 18 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK4.PAS IMPORT 17 Unit qsort;ππInterfaceππProcedure quicksort(Var s; left,right : Word);ππImplementationππProcedure quicksort(Var s; left,right : Word; SortType: sType);π { On the first call left should always be = to min and right = to max }π Varπ data : DataArr Absolute s;π pivotStr,π tempStr : String;π pivotLong,π tempLong : LongIntπ lower,π upper,π middle : Word;ππ Procedure swap(Var a,b);π Var x : DirRec Absolute a;π y : DirRec Absolute b;π t : DirRec;π beginπ t := x;π x := y;π y := t;π end;ππ beginπ lower := left;π upper := right;π middle:= (left + right) div 2;π Case SortType ofπ _name: pivotStr := data[middle].name;π _ext : pivotStr := data[middle].ext;π _size: pivotLong := data[middle].Lsize;π _date: pivotLong := data[middle].Ldate;π end; { Case SortType }π Repeatπ Case SortType ofπ _name: beginπ While data[lower].name < pivotStr do inc(lower);π While pivotStr < data[upper].name do dec(upper);π end;π _ext : beginπ While data[lower].ext < pivotStr do inc(lower);π While pivotStr < data[upper].ext do dec(upper);π end;π _size: beginπ While data[lower].Lsize < pivotLong do inc(lower);π While pivotLong < data[upper].Lsize do dec(upper);π end;π _date: beginπ While data[lower].Ldate < pivotLong do inc(lower);π While pivotLong < data[upper].Ldate do dec(upper);π end;π end; { Case SortType }π if lower <= upper then beginπ swap(data[lower],data[upper]);π inc(lower);π dec(upper);π end;π Until lower > upper;π if left < upper then quicksort(data,left,upper);π if lower < right then quicksort(data,lower,right);π end; { quicksort }ππππππππ 19 05-28-9313:57ALL SWAG SUPPORT TEAM QUICK5.PAS IMPORT 19 {π>I'm in need of a FAST way of finding the largest and the smallestπ>30 numbers out of about 1000 different numbers.ππ ...Assuming that the 1000 numbers are in random-order, I imagineπ that the simplest (perhaps fastest too) method would be to:ππ 1- Read the numbers in an Array.ππ 2- QuickSort the Array.ππ 3- First 30 and last 30 of Array are the numbers you want.ππ ...Here's a QuickSort demo Program that should help you With theπ sort:π}ππ{$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S+,V-}π{$M 60000,0,0}ππProgram QuickSort_Demo;πUsesπ Crt;ππConstπ co_MaxItem = 30000;ππTypeπ Item = Word;π ar_Item = Array[1..co_MaxItem] of Item;πππ (***** QuickSort routine. *)π (* *)πProcedure QuickSort({update} Var ar_Data : ar_Item;π {input } wo_Left,π wo_Right : Word);πVarπ Pivot,π TempItem : Item;π wo_Index1,π wo_Index2 : Word;πbeginπ wo_Index1 := wo_Left;π wo_Index2 := wo_Right;π Pivot := ar_Data[(wo_Left + wo_Right) div 2];π Repeatπ While (ar_Data[wo_Index1] < Pivot) doπ inc(wo_Index1);π While (Pivot < ar_Data[wo_Index2]) doπ dec(wo_Index2);π if (wo_Index1 <= wo_Index2) thenπ beginπ TempItem := ar_Data[wo_Index1];π ar_Data[wo_Index1] := ar_Data[wo_Index2];π ar_Data[wo_Index2] := TempItem;π inc(wo_Index1);π dec(wo_Index2)π endπ Until (wo_Index1 > wo_Index2);π if (wo_Left < wo_Index2) thenπ QuickSort(ar_Data, wo_Left, wo_Index2);π if (wo_Index1 < wo_Right) thenπ QuickSort(ar_Data, wo_Index1, wo_Right)πend; (* QuickSort. *)ππVarπ wo_Index : Word;π ar_Buffer : ar_Item;ππbeginπ Write('Creating ', co_MaxItem, ' random numbers... ');π For wo_Index := 1 to co_MaxItem doπ ar_Buffer[wo_Index] := random(65535);π Writeln('Finished!');π Write('Sorting ', co_MaxItem, ' random numbers... ');π QuickSort(ar_Buffer, 1, co_MaxItem);π Writeln('Finished!');π Writeln;π Writeln('Press the <ENTER> key to display all ', co_MaxItem,π ' sorted numbers...');π readln;π For wo_Index := 1 to co_MaxItem doπ Write(ar_Buffer[wo_Index]:8)πend.π 20 05-28-9313:57ALL SWAG SUPPORT TEAM RADIX1.PAS IMPORT 34 {π Here's my solution to your "contest". The first I'm rather proudπ of, it incorporates bAsm to beat your devilshly efficient CASEπ Implementation by a factor of 2x.ππ The second, I am rather disappointed With as it doesn't even comeπ CLOSE to TP's inbuilt STR Function. (The reason, I have found, isπ because TP's implementaion Uses a table based approach that wouldπ be hard to duplicate With Variable radixes. I am working on aπ Variable radix table now)πππ ****************************************************************π Converts String pointed to by S into unsigned Integer V. Noπ range or error checking is performed. Caller is responsible forπ ensuring that Radix is in proper range of 2-36, and that noπ invalid Characters exist in the String.π ****************************************************************π}πTypeπ pChar = ^chr_Array;π chr_Array = Array[0..255] of Char;π Byte_arry = Array[Char] of Byte;ππConstπ sym_tab : Byte_arry = (π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,1,2,3,4,5,6,7,8,9,π 0,0,0,0,0,0,0,10,11,12,13,14,15,16,17,π 18,19,20,21,22,23,24,25,26,27,28,29,30,π 31,32,33,34,35,0,0,0,0,0,0,10,11,12,13,π 14,15,16,17,18,19,20,21,22,23,24,25,26,π 27,28,29,30,31,32,33,34,35,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,π 0,0,0,0,0,0,0,0,0,0,0,0,0π );ππProcedure RadixVal(Var V:LongInt; S:PChar;Radix:Byte);πVarπ digit :Byte;π p, p2 :Pointer;π hiwd, lowd :Word;πbeginπ V := 0;π p := @S^[0];π p2 := @V;π Asmπ les bx, p2π push dsπ pop esπ lds si, pπ @loop3:π lea di, [sym_tab]π xor ah, ahπ lodsbπ cmp al, 0π je @quitπ add di, ax { index to Char position in table }π mov al, Byte PTR [di]π mov digit, alπ xor ah, ahπ mov al, Radixπ mov cx, axπ mul Word PTR [bx]π mov lowd, axπ mov hiwd, dxπ mov ax, cxπ mul Word PTR [bx+2] { mutliply high Word With radix }π add hiwd, ax { add result to previous result - assume hi result 0 }π mov ax, lowdπ mov dx, hiwdπ add al, digit { add digit value }π adc ah, 0 { resolve any carry }π mov [bx], ax { store final values }π mov [bx+2], dxπ jmp @loop3π @quit:π end;πend;ππ{π ****************************************************************π Convert unsigned Integer in V to String pointed to by S.π Radix determines the base to use in the conversion. No rangeπ checking is performed, the caller is responsible For ensuringπ the radix is in the proper range (2-36), and that V is positive.π ****************************************************************π}πTypeπ Char_arry = Array[0..35] of Char;ππConstπ symbols :Char_arry = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';ππProcedure RadixStr(V:LongInt; S:PChar; Radix:Byte);πVarπ digit, c :Byte;π ts :String;π p, p2 :Pointer;πbeginπ c := 255;π ts[255] := #0;π p := @V;π p2 := @ts[0];π Asmπ push dsπ lea si, [symbols]π les bx, pπ les di, p2π add di, 255π stdπ xor cx, cxπ mov cl, Radixπ @loop:π SEGES mov ax, Word PTR [bx]π SEGES mov dx, Word PTR [bx+2]π div cxπ SEGES mov Word PTR [bx], axπ SEGES mov Word PTR [bx+2], 0π mov digit, dlπ push siπ xor ah, ahπ mov al, digitπ add si, axπ movsbπ pop siπ dec cπ SEGES cmp Word PTR [bx], 0π je @doneπ SEGES cmp Word PTR [bx+2], 0π je @loopπ @done:π pop dsπ end;π ts[c] := Chr(255-c);π p := @S^[0];π Asmπ push dsπ cldπ lds si, p2π les di, pπ xor bx, bxπ mov bl, cπ add si, bxπ mov cx, 256π sub cl, cπ sbb ch, 0π rep movsbπ pop dsπ end;πend;π 21 05-28-9313:57ALL SWAG SUPPORT TEAM RADIX2.PAS IMPORT 16 {>...Assuming that the 1000 numbers are in random-order, I imagineπ> that the simplest (perhaps fastest too) method would be to:π> 1- Read the numbers in an Array.π> 2- QuickSort the Array.π> 3- First 30 and last 30 of Array are the numbers you want.ππ>Stop the presses, stop the presses!ππ <grin>ππ>Remember the recent Integer sort contest, on the Intelecπ>Programming conference?ππ ...Ah, yes... I always tend to Forget about that method.π Yes, a "count" sort would definitely be the fastest methodπ of sorting random numerical data.π ...What I had a few troubles figuring out from that postπ in the Intelec confrence, wasn't the "count sort" method,π but rather the "radix sort" or "digital sort" method,π where specific bits within each data element are usedπ to sort the data.ππ ...Here's the algorithm listed in Robert Sedgewick'sπ "Algorithms" book, published by Addison-Wesley Publishingπ Company, ISBN 0-201-06673-4 :π}ππProcedure RadixExchange(l, r, b:Integer);πVarπ t, i, j : Integer;πbeginπ if (r > l) and (b >= 0) thenπ beginπ i := l;π j := r;π Repeatπ While (bits(a[i], b, 1) = 0) and (i < j) doπ i := I + 1;π While (bits(a[j], b, 1) = 1) and (i < j) doπ j := j - j;π t := a[i];π a[i] := a;π a[j] := t;π Until (j = i);π if bits(a[r], b, 1) = 0 thenπ j := j + 1;π RadixExchange(l, (j - 1), b - 1);π RadixExchange(j, r, (b - 1));π end;πend;ππ{π>By toggling the high bit, the Integers are changed in a way that,π>conveniently, allows sorting by magnitude: from the "most negative"π>to "most positive," left to right, using an Array With unsignedπ>indexes numbering 0...FFFFh.ππ ...Why bother With the bit toggling at all? Why not just defineπ the Array's range as being: Array[-32768..32767] of Byte;π}ππ 22 05-28-9313:57ALL SWAG SUPPORT TEAM RADIXQUE.PAS IMPORT 16 Turbo Pascal Optimization Contest # 51.ππNo tangible prizes, just some bragging rights, and a brain workout.ππAssignment: Write conversion routines similar to VAL and STR that canπ handle a radix (base) of any number. For example, below isπ a straight Pascal Procedure to convert a String of any baseπ to a LongInt. Can you improve the speed of this routine,π and Write a correspondingly fast routine to convert from aπ LongInt to a String of any base?ππRules: No rules. BAsm is allowed, as long as the Functions areπ readily Compilable without the use of TAsm.ππJudging: Code will be tested on a 386-40 on March 10th, by beingπ placed into a loop With no output, like this:ππ StartTiming;π For Loop := 1 to 10000000 { ten million } doπ { Execute the test, no output }π WriteLn(StopTiming);ππReady, set, code! Here's the sample...ππ(* This Function converts an ASCIIZ String S in base Radix to LongInt Iπ * With no verification of radix validity. The calling Programmer isπ * responsible For insuring that the radix range is 2 through 36. Theπ * calling Programmer is also responsible For insuring that the passedπ * String contains only valid digits in the specified Radix. No checkingπ * is done on the individual digits of a given String. For bases 11-36π * the letters 'A'-'Z' represent the corresponding values.π *)ππProcedure StrtoLong(Var I : LongInt; S : PChar; Radix : Integer);π beginπ I := 0;π While S[0] <> #0 doπ beginπ Case S[0] of '0'..'9' : I := I * Radix + (ord(S[0])-48);π 'A'..'Z' : I := I * Radix + (ord(S[0])-54);π 'a'..'z' : I := I * Radix + (ord(S[0])-86);π Inc(s);π end;π end;ππ 23 05-28-9313:57ALL SWAG SUPPORT TEAM RADIXSRT.PAS IMPORT 24 {π> I agree... unFortunately the Radix algorithm (which is aπ> sophisticated modification of a Distribution Sort algorithm) isπ> very Complex, highly CPU dependent and highly data dependent.ππWe must be speaking of a different Radix Sort. Is the sort you areπtalking about sort numbers on the basis of their digits?ππ> My understanding is that a Radix sort cannot be implemented inπ> Pascal without using a majority of Asm (which means you might asπ> well code the whole thing in Asm.)ππ> assembly) or dig up some working code, I would love to play With it!ππ************************************************************************π* *π* Name : Joy Mukherjee *π* Date : Mar. 26, 1990 *π* Description : This is the Radix sort implemented in Pascal *π* *π************************************************************************π}ππProgram SortStuff;ππUses Crt, Dos;ππTypeπ AType = Array [1..400] of Integer;π Ptr = ^Node;π Node = Recordπ Info : Integer;π Link : Ptr;π end;π LType = Array [0..9] of Ptr;ππVarπ Ran : AType;π MaxData : Integer;ππProcedure ReadData (Var A : AType; Var MaxData : Integer);ππVar I : Integer;ππbeginπ MaxData := 400;π For I := 1 to 400 do A [I] := Random (9999);πend;ππProcedure WriteArray (A : AType; MaxData : Integer);ππVar I : Integer;ππbeginπ For I := 1 to MaxData doπ Write (A [I] : 5);π Writeln;πend;ππProcedure Insert (Var L : LType; Number, LN : Integer);ππVarπ P, Q : Ptr;ππbeginπ New (P);π P^.Info := Number;π P^.Link := Nil;π Q := L [LN];π if Q = Nil thenπ L [LN] := Pπ elseπ beginπ While Q^.Link <> Nil doπ Q := Q^.Link;π Q^.Link := P;π end;πend;πππProcedure Refill (Var A : AType; Var L : LType);πVarπ I, J : Integer;π P : Ptr;πbeginπ J := 1;π For I := 0 to 9 doπ beginπ P := L [I];π While P <> Nil doπ beginπ A [J] := P^.Info;π P := P^.Link;π J := J + 1;π end;π end;π For I := 0 to 9 doπ L [I] := Nil;πend;ππProcedure RadixSort (Var A : AType; MaxData : Integer);πVarπ L : LType;π I,π divisor,π ListNo,π Number : Integer;πbeginπ For I := 0 to 9 do L [I] := Nil;π divisor := 1;π While divisor <= 1000 doπ beginπ I := 1;π While I <= MaxData doπ beginπ Number := A [I];π ListNo := Number div divisor MOD 10;π Insert (L, Number, ListNo);π I := I + 1;π end;π Refill (A, L);π divisor := 10 * divisor;π end;πend;ππbeginπ ReadData (Ran, MaxData);π Writeln ('Unsorted : ');π WriteArray (Ran, MaxData);π RadixSort (Ran, MaxData);π Writeln ('Sorted : ');π WriteArray (Ran, MaxData);πend.π 24 05-28-9313:57ALL SWAG SUPPORT TEAM SHELL1.PAS IMPORT 14 { Arrrggghh. I hate Bubble sorts. Why don't you use Merge sort? It's a hellπ of a lot faster and if you have a large enough stack, there wouldn't beπ any problems. if you were not interested in doing a recursive sort, thenπ here is an example fo the Shell sort which is one of the most efficientπ non recursive sorts around.π}πππConstπ Max = 50;πTypeπ ArrayType = Array[1..Max] of Integer;ππVarπ Data, Temp : ArrayType;π Response : Char;π X, Iteration : Integer;ππProcedure ShellSort (Var Data : ArrayType;Var Iteration : Integer;π NumberItems : Integer);ππProcedure Sort (Var Data : ArrayType; Var Iteration : Integer;π NumberItems, Distance : Integer);ππVarπ X, Y : Integer;ππbegin {Sort}π Iteration := 0;π For Y := Distance + 1 to NumberItems Doπ begin {For}π X := Y - Distance;π While X > 0 Doπ begin {While}π if Data[X+Distance] < Data[X] thenπ begin {if}π Switch (Data[X+Distance], Data[X], Iteration);π X := X - Distance;π Iteration := Iteration + 1π end {if}π elseπ X := 0;π end; {While}π end {For}πend; {Sort}ππbegin {ShellSort}π Distance := NumberItems div 2;π While Distance > 0 doπ begin {While}π Sort (Data, Iteration, NumberItems, Distance);π Distance := Distance div 2π end; {While}πend; {ShellSort}π 25 05-28-9313:57ALL SWAG SUPPORT TEAM SOMESORT.PAS IMPORT 18 { Author: Brian Pape. }ππConstπ maxrange = 5000;ππTypeπ ListRange = 1..MaxRange;π list = Array[ListRange] of Integer;ππVarπ a,b: list;π i: Integer;ππProcedure BubbleSort(Var B : list; Terms : Integer);πVarπ J, Temp : Integer;π Changed : Boolean;π Last,π LastSwitch : Integer;πbeginπ changed := True;π Last := Terms-1;π While Changed doπ beginπ changed := False;π For J := 1 to Last doπ If B[J] > B[J+1] thenπ beginπ Temp := B[J];π B[J] := B[J+1];π B[J+1] := Temp;π Changed := True;π LastSwitch := j;π end; { If B[J] }π Last := LastSwitch -1;π end { While Changed }πend; { BubbleSort }ππProcedure Min_MaxSort(Var a : list; NumberTerms : ListRange);πVarπ temp,π i,l,r,π min,max,π tempMin,π tempMax,π indexMin,π indexMax,π s1,s2,s3,s4 : Integer;π changed : Boolean;πbeginπ l := 1; r := NumberTerms; max := MaxInt;π Repeatπ min := max;π changed := False;π max := 0;π For i := l to r doπ beginπ if a[i] > max thenπ beginπ changed := True;π Max := a[i];π indexMax := i;π end; { if }π if a[i] < min thenπ beginπ changed := True;π Min := a[i];π indexMin := i;π end; { if }π end; { For }ππ tempMin := a[indexMin];π tempMax := a[indexMax];π a[indexMax] := a[l];π a[l] := tempMin;π a[indexMin] := a[r];π a[r] := tempMax;π inc(l); dec(r);π Until (l>=r) or not changed;πend; { Min_MaxSort }πππProcedure ShellSort(Var a : list; NumberTerms : ListRange);πConstπ start = 1;π increment = 3; { division factor of terms }πVarπ i,j : ListRange;π t : Integer;π found : Boolean;πbeginπ i := start + increment;π While i <= NumberTerms doπ beginπ if a[i] < a[i - increment] thenπ beginπ j := 1;π t := a[i];π Repeatπ j := j - increment;π a[j + increment] := a[j];π if j = 1 thenπ found := Trueπ elseπ found := a[j - increment] <= t;π Until found;π a[j] := t;π end; { if }π i := i + increment;π end; { While }πend; { ShellSort }π 26 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-DLL.PAS IMPORT 25 {π> Now, I gotta work on sortin' em. I believe I can 'swap' theπ> positions of the Pointers eh?π>π> I can't figure out how to swap the Pointers. Could you pleaseπ> gimme a wee bit more help? I've just started doing sorts, andπ> have only used the Bubble sort at the moment in a few Programs,π> so I'm still a little shakey on sorts. I understand the Bubbleππ Here's an *example* on how to sort a linked list. There are moreπ efficient ways to sort a list, but this gives you all theπ essential elements in doing a sort. (note that ListPtr is a doublyπ linked list)π}ππProcedure SortList(Var FCL:ListPtr);πVarπ TempAnchor, TemPtr1, TemPtr2 :ListPtr;ππ Procedure MoveLink(Var Anchor, Ptr1, Ptr2 :ListPtr);π Varπ TemPtr3, TemPtr4 :ListPtr;π beginπ TemPtr3 := Ptr1^.Next; { temporary Pointer preserves oldπ Pointer value }π TemPtr4 := Ptr2^.Last; { ditto }ππ Ptr2^.Last := Ptr1; { do the Pointer swap }π Ptr1^.Next := Ptr2;ππ Ptr1^.Last^.Next := TemPtr3; { fixup secondary Pointers }π TemPtr3^.Last := Ptr1^.Last;π Ptr1^.Last := TemPtr4;ππ if TemPtr4 <> NIL then { if temporary Pointer is notπ NIL, then it has to point toπ swapped Pointer }π TemPtr4^.Next := Ptr1;ππ if Ptr1^.Last = NIL then { if swapped Pointer points toπ preceding NIL Pointer, thisπ Pointer is the new root. }π Anchor := Ptr1;π end;ππbeginπ TempAnchor := FCL; { holds root of list during sort }π TemPtr2 := TempAnchor; { TemPtr2 points to current data beingπ Compared }π Repeatπ TemPtr1 := TemPtr2; { TemPtr1 points to the next orderedπ data }π FCL := TemPtr2; { start FCL at root of UNSorTED list -π sorted data precede this Pointer }π Repeatπ FCL := FCL^.Next;π if FCL^.data < TemPtr1^.data then { Compare data values }π TemPtr1 := FCL; { if necessary, reset TemPtr1 toπ point to the new ordered value }π Until FCL^.Next = NIL; { keep going Until you reach theπ end of the list. After Exit,π the next value in order will beπ pointed to by TemPtr1 }π if TemPtr1<>TemPtr2 then { if TemPtr1 changed, a valueπ was found out of order }π MoveLink(TempAnchor,TemPtr1,TemPtr2) { then swap Pointers }π elseπ TemPtr2 := TemPtr2^.Next; { else advance to the nextπ Pointer in list }π Until TemPtr2^.Next = NIL; { Until we are finished sortingπ the list }π FCL := TempAnchor; { changes root Pointer to new root value }πend;ππ 27 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-LL.PAS IMPORT 25 {π> I have a linked list structure that I would like to sort in one ofπ> four different ways. I can sort Arrays using QuickSort, etc., but have noπ> experience sorting linked lists. Does anyone have any source codeπ> (preferably) or any suggestions on how to proceed? Any help would beπ> appreciated.ππI got Modula-2 code I wrote about one year ago. I post an excerpt fromπthe Implementation MODULE. It should be no problem to convert it toπPascal, since the languages are rather similar.π}πProcedure LISTSort(Var List : LISTType;π Ascending: Boolean);ππVarπ Last : NodeTypePtr;π Result: LISTCompareResultType;ππ Procedure TailIns( Rec : NodeTypePtr;π Var First: NodeTypePtr;π Var Last : NodeTypePtr);ππ beginπ if (First=NIL) then First := Rec else Last^.Next := Rec end;π Last := Recπ end TailIns;ππ Procedure MergeLists( a: NodeTypePtr;π b: NodeTypePtr): NodeTypePtr;ππ Varπ First: NodeTypePtr;π Last : NodeTypePtr;π Help : NodeTypePtr;ππ beginπ First := NIL;π While (b#NIL) doπ if (a=NIL) thenπ a := b; b := NILπ elseπ if (Classes[List^.ClassID].Cmp(b^.DataPtr,a^.DataPtr)=Result)π thenπ Help := a; a := a^.Nextπ elseπ Help := b; b := b^.Nextπ end;π Help^.Next := NIL;π TailIns(Help,First,Last)π endπ end;π TailIns(a,First,Last);π RETURN(First)π end MergeLists;ππ Procedure MergeSort(Var Root: NodeTypePtr;π N : CARDinAL): NodeTypePtr;ππ Varπ Help: NodeTypePtr;π a,b : NodeTypePtr;ππ beginπ if (Root=NIL) thenπ RETURN(NIL)π ELSif (N>1) thenπ a := MergeSort(Root,N div 2);π b := MergeSort(Root,(N+1) div 2);π RETURN(MergeLists(a,b))π elseπ Help := Root;π Root := Root^.Next;π Help^.Next := NIL;π RETURN(Help)π endπ end MergeSort;ππbeginπ if (List^.N<2) then RETURN end;π if (Ascending) then Result := LISTGreater else Result := LISTLess end;π List^.top^.Next := MergeSort(List^.top^.Next,List^.N);π Last := List^.top;π List^.Cursor := List^.top^.Next;π While (List^.Cursor#NIL) doπ List^.Cursor^.Prev := Last;π Last := List^.Cursor;π List^.Cursor := List^.Cursor^.Nextπ end;π Last^.Next := List^.Bottom;π List^.Bottom^.Prev := Last;π List^.CurPos := 1;π List^.Cursor := List^.top^.Nextπend LISTSort;ππ{πThe basic data structure is defined as follows:π}ππConstπ MaxClasses = 256;ππTypeπ NodeTypePtr = Pointer to NodeType;ππ NodeType = Recordπ Prev : NodeTypePtr;π Next : NodeTypePtr;π DataPtr: ADDRESSπ end;ππ LISTType = Pointer to ListType;ππ ListType = Recordπ top : NodeTypePtr;π Bottom : NodeTypePtr;π Cursor : NodeTypePtr;π N : CARDinAL;π CurPos : CARDinAL;π ClassID: CARDinALπ end;ππ ClassType = Recordπ Cmp : LISTCompareProcType;π Bytes: CARDinALπ end;ππVarπ Classes: Array [0..MaxClasses-1] of ClassType;π 28 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-PTR.PAS IMPORT 11 {π This is using the concept of a PoINter Array (an Array of PoINters). Itπallows For a _very_ large amount of data, sINce you allocate each Record spaceπof the Heap. You must allocate each space For each Record as you create theπRecord:π}ππ New (INFOSTUFF[3]); { allocates space For 3rd Record }π With INFOSTUFF[6]^ do { works With 6th Record }π beginπ NAME := 'Patrick Edwards'; IDNUM := 60000; MOM := ''π end;ππ The sort could be:ππVar T : INFO;πProcedure L_HSorT (LEFT,RIGHT : Word); { Lo-Hi QuickSort }πVar LOWER,UPPER,MIDDLE : Word;π PIVOT : INFO;πbeginπ LOWER := LEFT; UPPER := RIGHT; MIDDLE := (LEFT+RIGHT) div 2;π PIVOT := INFOSTUFF[MIDDLE]^;π Repeatπ While INFOSTUFF[LOWER]^.NAME < PIVOT.NAME do INc(LOWER);π While PIVOT.NAME < INFOSTUFF[UPPER]^.NAME do Dec(UPPER);π if LOWER <= UPPER thenπ beginπ T := INFOSTUFF[LOWER]^; INFOSTUFF[LOWER]^ := INFOSTUFF[UPPER]^;π INFOSTUFF[UPPER]^ := T;π INc (LOWER); Dec (UPPER);π end;π Until LOWER > UPPER;π if LEFT < UPPER then L_HSorT (LEFT, UPPER);π if LOWER < RIGHT then L_HSorT (LOWER, RIGHT);πend; { L_HSorT }ππ{ called as:ππL_HSorT (1,10);π}π 29 05-28-9313:57ALL SWAG SUPPORT TEAM SORT-STR.PAS IMPORT 7 {πIt gets better and better. The Procedure below is incredibly fast in theπsorting of the Strings in the Arrays! 1.2 sec For 1485 Strings.π}ππProcedure Sort(item : PFilearr; Last : Integer);πVarπ i, j : Integer;π span : Integer;πbeginπ item^[0] := newstr(' ');π span := Last shr 1; {Span=Last/2}π While span > 0 doπ beginπ For i := Span to Last - 1 doπ beginπ For j := (i - Span + 1) downto 1 doπ if item^[j]^ <= item^[j + Span]^ thenπ j:=1 {to make it quit the j-loop}π elseπ begin {swap Array(j) With Array(j+Span)}π item^[0] := item^[j];π item^[j] := item^[j + Span];π item^[j + Span] := item^[0];π end;π end;π Span := Span shr 1; {Span=Span/2}π end;πend;π 30 05-28-9313:57ALL SWAG SUPPORT TEAM SORTFAST.PAS IMPORT 21 {π> I might share With you a sorting Procedure which I developed Forπ> 'those Arrays we were talking about:π> ...π> Exeperimentally I used it on 1485 Strings, which took about 3 secπ> on my 386DX40. Could you advise on some method to do it evenπ> faster?ππI'll share With you a little sort routine which I use often in my Programsπwhenever I need a fast and efficient routine With very low overhead... It Usesπconsiderably less code than your example, and should outperForm it. (It wouldπbe even faster if it was all coded in Assembly!-- hint hint DJ) :-)π}ππProcedure Sort_It( totalItems : Word );ππ Function Is_Less( TemPtr1, TemPtr2 : Pointer ) : Boolean;π beginπ Is_Less := ( YourStruct(TemPtr1^).Item < YourStruct(TemPtr2^).Item );π end;ππVarπ I,J : Word;π Cur : Word;ππbeginπ For I := 1 to Pred(totalItems) doπ beginπ Cur := I;ππ For J := I + 1 to totalItems doπ if Is_Less( Item[J], Item[Cur] ) thenπ ExchangeLongInts( LongInt(Item[J]), LongInt(Item[Cur]) );π end; { For }ππend; { Proc }ππ{πThere's a couple things I should explain: The "ExchangeLongInts" Procedure isπfrom the TurboPower Opro's OpInline Unit. All it does is exchange two LongIntπTypes without you having to use a temporary Variable. It's fast and convenient,πbut not the only possible solution here. (I'm Typecasting the Pointer into aπLongInt For a 4-Byte swap.)ππ"totalItems" is the total number of items in your Array to sort.ππ"Item" is the actual Array; Item : Array[1..xx] of Pointer_to_Record;ππ"YourStruct" used in the "Is_Less" Function is Typecasting the actual structureπor Record that "Item" is referring to. It's the only portion of the code whichπlooks at your actual data. to reverse the sort order, simply change the "<" toπ">". to change what is being sorted, just change the ".Item" to something elseπlike ".Name" or ".Zip" or whatever else might be contained in your structure.ππThis routine is simple, has a minimum amount of code, Uses very little stack,πworks only With Pointers and you are only sorting memory addresses; it neverπactually move any of your physical data. (if you did, then it would be slow.)ππIt'll sort several thousand items in only a couple seconds even on slowerπmachines, and is super on small volume runs. I would imagine that it wouldπ(90 min left), (H)elp, More? start loosing steam around 1,000 to 2,000 items, but For me, it's the bestπchoice when memory is at a premium and the Arrays are fairly small.π}ππ 31 05-28-9313:57ALL SWAG SUPPORT TEAM TIMESORT.PAS IMPORT 69 {I wrote a small Program to bench both sort routines we posted. It was anπinteresting test, however it did raise a couple questions For me, which I'llπget to in a moment. (The following Program can be used as a skeleton For tryingπother sort routines too.)ππNeedless to say, the routine you posted was dramatically faster than the one Iπposted, even though both routines are non-recursive simple sorts.ππThe maximum efficient load of the routine you posted appears to be about 3000πelements. After that, additonal elements add time exponentially. For example,πit will sort 3000 elements in 5.1 seconds, but 5000 elements takes almost 16πseconds. The sort I posted became un-benchable [bearable] at about 3000πelements when it took over a minute to Complete. I didn't test it beyond thisπpoint.ππHere are the results from my 386 33Mhz machine-- your algorithm.ππ 500 Elements - 0.1 Secondsπ 1000 Elements - 0.8 Secondsπ 1500 Elements - 1.4 Secondsπ 2000 Elements - 2.6 Secondsπ 3000 Elements - 5.1 Seconds <- Peak efficiency reachedπ 5000 Elements - 15.8 SecondsππHere is the Program I used to benchmark with. I made it so that you couldπ"tweak" portions of the sort and re-run the Program.ππIncidentally, I also Compiled this Program under Stony Brook's Pascal Plus andπwas suprised to find that it ran substantially slower. All optimizations on.ππRange Checking ($R+) exactly Doubled the time it took to sort.ππChanging "Span+1" to Succ(Span) and "total-1" to Pred(total) made the routineπabout 3% faster. However the routine then neglected to sort that last twoπelements. Adding "Inc(total,2)" solved the problem but I'm not sure why. I didπnot expect this behavior. Perhaps someone could explain why?ππI added a temporary Pointer Variable to your routine in place of the "NewStr('π... ')" code you used to simplify it.ππand one last thing... Using OPRO's OpInline Function calledπ"ExchangeLongInts()" to do the swapping instead of using a temporary Varπincreased speed another 2% (Evident at > 2000 elements.) However I did notπinclude this so that anyone interested could Compile and run this without extraπUnits.π}ππ{$A+,B-,D-,E-,F-,G-,I+,L+,N-,O-,P-,Q+,R-,S+,T-,V-,X-,Y+}π{$M 32768,0,655360}ππProgram Sort_Test; { Sorting Benchmark Using P. Beeftink's Algorithm }ππTypeπ SmallArrPtr = ^SmallArr;π SmallArr = Array[1..10] of Char; { Skip String & Length Byte }ππ TTimeString = String[20];πππVarπ SortArray : Array[1..5000] of SmallArrPtr; { A LARGE Array }ππ TickCount : LongInt Absolute $0040:$006C;π { TickCount : LongInt VOLATILE Absolute $0040:$006C; } { For Pascal+ }π Tstart,π Ttime : LongInt;ππ{------------------------------------------------------------------------}πProcedure StartTiming;πbeginπ TStart := TickCount;ππ {start at the beginning of a tick!}π Repeat Until TStart <> TickCount;ππ TStart := TickCount;ππend;π{------------------------------------------------------------------------}πProcedure StopTiming;πbeginπ TTime := TickCount - TStart;πend;π{------------------------------------------------------------------------}πFunction Elapsed : TTimeString;πVar Temp : TTimeString;π Sec10 : LongInt;πbeginππ Sec10 := TTime * 2470 div 4497;π Str( Sec10 : 4, Temp );ππ if Temp[1] = ' ' then Temp[1] := '0';ππ Inc( Temp[0] );π Temp[ Length(Temp) ] := Temp[ Pred( Length( Temp ) ) ];π Temp[ Pred( length( Temp ) ) ] := '.';ππ Elapsed := Temp;πend;π{------------------------------------------------------------------------}πProcedure MakeRandomStrings( NumtoMake : Word );πVar RNum,π I,S : Word;π Temp : String;πbeginππ Temp := '';π Temp[0] := Chr( 10 );π Randomize;ππ For I := 1 to NumtoMake doπ beginππ For S := 1 to 10 do { Create Random Strings 10 Chars in length }π beginπ RNum := Random(26);π Temp[S] := Chr( RNum + 65 );π end;ππ Move( Temp[1], SortArray[I]^, 10 );ππ end;ππend; { Proc }π{------------------------------------------------------------------------}πProcedure KDSort( total : Word );π {-My simple sort routine as posted in Pascal Echo }π { With 2 slight modifications }πVarπ i,j,π Current : Word;π TempPtr : Pointer;πbeginππ For I := 1 to total doπ beginππ Current := I;ππ For J := Succ(I) to total doπ beginπ if SortArray[J]^ < SortArray[Current]^ thenπ beginπ TempPtr := SortArray[j];π SortArray[j] := SortArray[Current];π SortArray[Current] := TempPtr;π end; {if}π end; {For}ππ end; {For}ππend;π{------------------------------------------------------------------------}πProcedure PBSort(total : Integer);π {-Peter Beeftink's Sort as Posted in Pascal Echo }π { Also With slight modifications }πVarπ I,j : Integer;π Span : Integer;π TempPtr : Pointer;πbeginππ Inc(total,2); { Required to Compensate For PRED and SUCC ? }ππ Span := total SHR $01;ππ While Span > 0 doπ beginππ For I := Span to Pred(total) {total-1} doπ beginππ For j := (I - Succ(Span) {Span+1} ) Downto 1 doπ if (SortArray[j]^ <= SortArray[j+Span]^) then j := 1 elseπ beginπ TempPtr := SortArray[j];π SortArray[j] := SortArray[j+Span];π SortArray[j+Span] := TempPtr;π end;ππ end; {For}ππ Span := Span SHR $01; { This does help speed over Span div 2! }ππ end; {WhIle}ππend;π{------------------------------------------------------------------------}πProcedure Do_Sorting( SortAmount : Word );πbeginππ MakeRandomStrings(SortAmount);ππ Write('Sorting... ');ππ StartTiming;ππ PBSort(SortAmount); { Change to KDSort() to bench second sort routine }ππ StopTiming;ππ WriteLn(SortAmount:5,' Elements - ',Elapsed,' Seconds');ππend;π{------------------------------------------------------------------------}πVar C : Word;ππbeginππ if MaxAvail < 5000 * Sizeof(SmallArr) then Halt; { not enough memory! }ππ For C := 1 to 5000 do { pre-allocate up front }π GetMem(SortArray[C],Sizeof(SmallArr));πππ Do_Sorting( 500 ); { Add more Do_Sorting()'s For whatever count }π Do_Sorting( 1000 ); { you wish to test with. }π Do_Sorting( 1500 );π Do_Sorting( 2000 );π Do_Sorting( 3000 );π Do_Sorting( 5000 );πππ { Un-comment the following if you wish to see the sorted output }ππ {π For C := 1 to 5000 do { Change 5000 to the amount you sorted }π WriteLn( SortArray[C]^ );πππ For C := 1 to 5000 doπ FreeMem(SortArray[C],Sizeof(SmallArr));ππend.π{πI plugged in a QuickSort algorithm in the "skeleton" Program in my previousπmessage to test perFormance. Here are the results:ππ 500 Elements - 0.1 Secondsπ 1000 Elements - 0.2 Secondsπ 1500 Elements - 0.4 Secondsπ 2000 Elements - 0.6 Secondsπ 3000 Elements - 0.9 Secondsπ 5000 Elements - 1.8 SecondsππVery fast indeed. I modified the algorithm to sort only by Pointers, andπoptimized a couple spots. Again, a slight speed increase is noted using OPRO'sπExchangeLongInts() in leu of using temporary Variables in 1 spot. if you haveπOPRO, replace them and you reduce the number of instructions by 2 perπiteration.ππThis is a split-list recursive sort. Works by making a pass through the entireπArray first and moves all "small" data to the left, and all "Large" data to theπright. then it sorts each half seperately.ππTake the following code segment and "plug" it into the skeleton in my previousπmessage. then change the "PBSort(SortAmount)" to "QuickSort(SortAmount)" to runπthe tests.ππHere is the code segment:ππ{------------------------------------------------------------------------}πProcedure QuickSort( total : Integer );π {------------------------------------------}π Procedure recQuickSort( L, R : Integer );π Var K,I,J : Integer;π T,π Temp : Pointer;ππ beginππ if L < R thenπ beginπ T := SortArray[L];π I := Pred(L);π J := L;π K := Succ(R);ππ While Succ(J) < K doπ if SortArray[Succ(J)]^ < SmallArrPtr(T)^ thenπ beginπ Inc(I,1);π Inc(J,1);π SortArray[I] := SortArray[J];π SortArray[j] := T;π end {if}π elseπ if SortArray[Succ(J)]^ > SmallArrPtr(T)^ thenπ beginπ Dec(K,1);π Temp := SortArray[K];π SortArray[K] := SortArray[Succ(J)];π SortArray[Succ(J)] := Temp;π end {if}π elseπ Inc(J,1);ππ recQuickSort(L,I);π recQuickSort(K,R);ππ end; { if L < R }ππ end; { Proc recQuickSort }π {------------------------------------------}ππbeginππ recQuickSort(1,total);ππend;{QuickSort}π{------------------------------------------------------------------------}π
